perm filename PARSE.OLD[AL,HE]4 blob
sn#312325 filedate 1977-10-23 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00065 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00006 00002 UPDATES TO PARSE BY MSM
C00010 00003 the AL to S-expression translator AND MSM SWITCHES
C00015 00004 ! statement, operator, sex, require, move definitions
C00023 00005 ! brace, condition_monitor, dimension, misc reserved word definitions
C00025 00006 ! dec_name, declaration names for input and output
C00027 00007 ! operators
C00032 00008 ! reserved_words
C00035 00009 ! init_reserved
C00037 00010 ! predefined constants
C00040 00011 ! predefined macros
C00041 00012 ! compiler switches and control tables
C00044 00013 ! hash, declaration of debugging variables, start of hidden_parse
C00047 00014 ! ---- DECLARATIONS ----
C00052 00015 ! record declarations
C00058 00016 ! other declarations
C00060 00017 ! error, error_recovery, error_reject, print, file_indent
C00074 00018 ! process_switches, got_input, got_output, open_logging_file, open_new_file,check_want_copy
C00081 00019 ! push_source_list,pop_source_list
C00083 00020 ! id info processing routines
C00085 00021 ! read, push_macro_delimiters
C00089 00022 ! macro handling routine
C00097 00023 ! expand_macro
C00102 00024 ! get_token
C00114 00025 ! check_token,check_token_type
C00118 00026 ! check, inverse, multiply and divide dimensions ! CHECK_EXP_TYPE_DIMENS
C00123 00027 ! check_entry,insert_entry into tables
C00128 00028 ! reduce, fail_up,vmake_R,vv_trans_R
C00131 00029 ! tmake_r, fmake_r
C00133 00030 ! sneg_R,rinv_R, sabs_R
C00136 00031 ! plus_R,minus_R
C00139 00032 ! times_R
C00143 00033 ! rot_R, wrt_R
C00147 00034 ! →_R
C00149 00035 ! reduce execution starts here
C00153 00036 ! printexpr
C00154 00037 ! string_expr
C00157 00038 ! p_exp2
C00159 00039 ! parse_special
C00166 00040 ! p_exp2 execution begins here, p_exp
C00173 00041 ! P_condition
C00181 00042 ! P_clauses, T_gen
C00193 00043 ! P_statement, F_state, modify_continue, modify_flush
C00197 00044 ! begin_P,end_P, open_paren_P
C00203 00045 ! define_P,declare_P,global_P
C00209 00046 ! if_P, plan_P, while_P
C00212 00047 ! for_P
C00215 00048 ! move_P
C00217 00049 ! affix_p,unfix_p
C00222 00050 ! signal_p, wait_p
C00224 00051 ! when_P
C00227 00052 ! dump_P
C00229 00053 ! assert_P
C00232 00054 ! on_P, reference_P
C00234 00055 ! open_P,center_P,stop_P,enable_P,disable_P
C00237 00056 ! require_P
C00244 00057 ! dimension_P
C00250 00058 ! string_P, integer_P
C00252 00059 ! abort_P, note_P,comment_P,speed_factor_P
C00255 00060 ! P_statement execution starts here
C00265 00061 ! execution starts here, initialization
C00268 00062 ! set up input and output
C00272 00063 ! set up predefined dimensions, constants, macros and variables
C00275 00064 ! PARSE PROGRAM
C00277 00065 ! SWAP TO AL COMPILER
C00279 ENDMK
C⊗;
COMMENT UPDATES TO PARSE BY MSM
9-15-77 FIXED BUG THAT MAKES INV(A)*B TO (TINVRT (TTMUL A B))
BY ADDING "INV" TO PARSE_SPECIAL
6- 7-77 PREDEFINED MACROS
ADJACENT MACRO BUG FIXED
6- 1-77 CODE FOR NEW FORCE STUFF
5-19-77 UNARY + AND - FINALLY WORK, SIGH
5- 3-77 STRICT DIMENSIONAL CHECKING NOW DEFAULT
3-16-77 ENABLE/DISABLE
MESSAGE END OF EACH BLOCK GIVING LIST OF VARIABLES NOT DEFINED AND
NOT USED
REMOVED PARSESHIT
1- 9-77 MORE MEANINGFUL ERROR MESSAGES
1- 9-77 CAN CORRECT MORE ERRORS
WILL NOT ACCEPT DIMENSIONS ON ANYTHING EXCEPT SCALARS AND VECTORS.
1- 5-77 ACCEPTS STRING DEFINITIONS
12-25-76 CAN CORRECT MINOR ERRORS IN SOURCE CODE IN_LINE
12-23-76 CAN ACCEPT TTY INPUT AS A FILE
12-21-76 ACCEPTS DIMENSIONS ON CONDITION MONITORS
CREATES NEW DECLARATIONS IF UNDECLARED TERM USED IN LHS OF ASSIGNMENT
12-15-76 BAIL CAN BE CALLED IN FROM REQUIRE SWITCHES INSTRUCTIONS
DEFAULT AND ONLY ACCEPTABLE DIMENSIONS OF FRAME IS DISTANCE
TRANS SHOULD BE DIMENSIONLESS
12-14-76 NEW SETUP FOR RESERVED WORD DEFINITIONS, ETC.
ERROR RECOVERY 55, WHEN FILE ASKED FOR DOES NOT EXIST
COMBINATION OF PLUS_R,MINUS_R
COMBINATION OF TMAKE_R, FMAKE_R
12-10-76 WHEN ERROR OF MACRO WITH PARAMETERS ACTUAL PARAMETERS SUBSTITUTED
ACCEPTS ONLY DISTANCE VECTOR ETC NO LONGER VECTOR DISTANCE
REQUIRE BAIL ADDED
12- 7-76 MACRO EXPANSION OF TEXT OK
12- 6-76 REQUIRE COMMENT_DELIMITERS
11-16-76 NEW CHECK_ENTRY AND INSERT_ENTRY PROCEDURES
11-15-76 INSERTION OF STRICT_DIMEN_CHECK SWITCH
ALL PREDEFINED CONSTANTS DECLARED DIMENSIONLESS
11-14-76 DIMENSIONLESS DECLARATION COERCED TO TYPE OF EXPRESSION
XHAT,YHAT,ZHAT MADE DIMENSIONLESS
11-6-76 NEW WAY OF COMPUTING DIMENSIONS
11-2-76 CHANGE LABEL TO STMLAB ON PG 6
11-2-76 CHANGES TO DECLARE_P TO allow default of distance to frames
11-2-76 LN49 PG 24 ADDED TO GIVE DIMENSION OF FRAME AS DISTANCE
11-2-76 ADDED ELSE DIM←0 AFTER SECOND IF STATEMENT TO CURE BUG ON PG 41 DECLARE_P
11-1-76 WOBBLE COMMAND IMPLEMENTED
10-29-76 LOGGING FEATURE IMPLEMENTED
10-27-76 TVSUB AND VSUB IMPLEMENTED
10-18-76 CHANGE STOP BLUE OR YELLOW TO STOP BARM OR YARM;
comment the AL to S-expression translator AND MSM SWITCHES;
Begin "PARSE"
REQUIRE 1024 STRING_PDL; REQUIRE 1024 STRING_SPACE; REQUIRE 1024 SYSTEM_PDL;
require "[][]" delimiters;
define
α =[begin],
β =[end],
! =[comment],
tab ='11,
alt ='175,
lf ='12,
ff ='14,
cr ='15,
space ='40,
dquote ='42,
squote ='47,
rubout ='177,
crlf =[('15&'12)],
ampersand ='46,
id_hasher =256,
macro_hasher =16,
metric_hasher =16,
reserved_hasher =256,
RPTR =[RECORD_POINTER],
RCLASS =[RECORD_CLASS],
preload_array(name, defs, type, first, len)=[
preload_with defs null; type array name[first:first+len] ];
! N.B. -- preload_array always creates an array 1 longer than requested;
! if /nB is set in the command line then assume he wants a debugging parser;
require "<><>" delimiters;
ifc ¬declaration(debug_compile) thenc
define
decipher_debug(a)=<
assignc a=cvms(compiler!banner)[2 to ∞-1];
assignc a=cvps(a)[length(scanc(cvps(a), lf, null, "IA"))+1 for ∞];
assignc a=cvps(a)[length(scanc(cvps(a), tab, null, "IA"))+1 for ∞];
assignc a=cvps(a)[length(scanc(cvps(a), space, null, "IA"))+1 for 1];
"a">;
ifc decipher_debug()="0"
thenc define debug_compile=false;
elsec define debug_compile=true;
endc
endc
define
decipher_compiletime(a)=<
assignc a=cvms(compiler!banner)[2 to ∞-1];
assignc a=cvps(a)[length(scanc(cvps(a), tab, null, "IA"))+6 for 21];
"a">;
require unstack_delimiters;
require ifc ¬debug_compile
thenc " NON-" elsec " " endc & "DEBUGGING VERSION " message;
ifc debug_compile thenc EXTERNAL PROCEDURE BAIL;
REQUIRE "LA" ERROR_MODES; ! to compile and go home when system busy;
endc
define
indices(name, postfix)=[
redefine xxcount=0;
redefine xx(xxarg)=[
redefine xxtemp=[define xxarg] & [postfix=xxcount];
xxtemp;
redefine xxcount=xxcount+1;];
name];
! ID postfix conventions
_VALUE AL data types
_RES reserved word types
_beg reserved word group begin
_end reserved word group end
_R REDUCE action routines
_P PARSE action routines
_TOKEN scanner token types
_CM condition monitors
_X indices of various sorts
_METRIC dimensional analysis non-sense
_DIMEN how to combine various matrix operands
_TYPE to decide which table to insert into
;
define id_type_table=0,
macro_type_table = 1,
macro_in_macro_type_table = 2,
dimension_type_table = 3 ;
! **********; require "SNAILR[AL,HE]" source_file; ! **********;
INTEGER PROCEDURE ___TIME;
BEGIN
INTEGER __T;
quick_code
setz '13, ;
calli '13,'27 ;
movem '13,__T ;
end;
RETURN(__T);
END;
! ************ MSM SWITCHES *************;
DEFINE DEFIN_PRINT_SWITCH = FALSE;
! statement, operator, sex, require, move definitions;
redefine xx(str)=[
redefine reserved_X_count=reserved_X_count+1;
redefine xx_temp="define " & "str" & "_RES=reserved_X_count";
xx_temp;];
redefine yy(str,str2)=[];
redefine zz(str)=[
redefine reserved_X_count=reserved_X_count+1;
redefine zz_temp="define " & "str" & "_RES=reserved_X_count";
zz_temp;];
define statement_definitions=[
xx(BEGIN)
yy(COBEGIN)
xx(END)
yy(COEND)
yy([;])
zz(OPEN_PAREN)
yy([(])
zz(DECLARE)
yy(SCALAR, scalar_value)
yy(VECTOR, vector_value)
yy(ROT, rot_value)
yy(FRAME, frame_value)
yy(PLANE, plane_value)
yy(TRANS, trans_value)
yy(EVENT, event_value)
yy(ATOM, atom_value)
yy(WORLD, world_value)
yy(CM_LABEL, cm_label_value)
yy(CLC_LABEL, clc_label_value)
yy(CH_LABEL, ch_label_value)
yy(LABEL, label_value)
xx(GLOBAL)
xx(IF)
xx(PLAN)
xx(WHILE)
xx(FOR)
xx(MOVE)
xx(AFFIX)
xx(UNFIX)
xx(SIGNAL)
xx(WAIT)
xx(WHEN)
xx(DUMP)
xx(ASSERT)
yy(DENY)
xx(ON)
yy(DEFER)
xx(REFERENCE)
xx(OPEN)
yy(CLOSE)
xx(CENTER)
xx(STOP)
xx(SPEED_FACTOR)
xx(DEFINE)
xx(REQUIRE)
xx(DIMENSION)
xx(INTEGER)
xx(STRING)
yy(NEW_STRING)
yy(OLD_STRING)
xx(COMMENT)
xx(ABORT)
yy(PRINT)
yy(PAUSE)
xx(NOTE)
yy(NOTE1)
yy(NOTE2)
xx(ENABLE)
xx(DISABLE)
];
define sex_definitions = [
zz(SEX)
yy(DSKIN)
yy(NULL)
yy(AFFIX)
yy(COMMENT)
yy(ALSO)
yy(SPEC)
yy(ON)
yy(EV)
yy(CMABLE)
yy(UNFIX)
yy(PR)
yy(CLC)
yy(CHG)
yy(BL)
yy(CO)
yy(FO)
yy(WH)
yy(IF)
yy(PAUSE)
yy(ABORT)
yy(AS)
yy(CIF)
yy(PAS)
yy(ASSERT)
yy(DENY)
yy(AF)
yy(SF)
yy(MO)
yy(OPERATE)
yy(CENTER)
yy(STOP)
yy(DURATION)
yy(FORCE)
yy(PRINT)
yy(VIA)
yy(VELOCITY)
yy(ARRIVAL)
yy(DEPARTURE)
yy(OPENING)
yy(WOBBLE)
yy(EX)
yy(VA)
yy(SC)
yy(PVL)
yy(NW)
yy(DBD)
yy(NOTE)
yy(NOTE1)
yy(NOTE2)
yy(GAS)
yy(NOMV)
yy(BIND)
yy(NOOP)
yy(SADD)
yy(SSUB)
yy(SMUL)
yy(SNEG)
yy(SDIV)
yy(SLT)
yy(SEQ)
yy(SLE)
yy(SGE)
yy(SNE)
yy(SGT)
yy(AND)
yy(OR)
yy(NOT)
yy(VMAGN)
yy(VDOT)
yy(VMAKE)
yy(SVMUL)
yy(VADD)
yy(VSUB)
yy(RVMUL)
yy(TVMUL)
yy(AXIS)
yy(RMAGN)
yy(UVECT)
yy(POS)
yy(ORIENT)
yy(RRMUL)
yy(AXW_ROTN)
yy(TMAKE)
yy(FTOF)
yy(TVADD)
yy(TVSUB)
yy(TTMUL)
yy(TINVRT)
yy(DEPR)
yy(FMAKE)
yy(GVAR)
yy(SVAR)
yy(VVAR)
yy(TVAR)
yy(RVAR)
yy(FVAR)
yy(ATOM)
yy(EVAR)
yy(WVAR)
yy(CLCLAB)
yy(CHGLAB)
yy(OMNLAB)
yy(STMLAB)
yy(SPEED_FACTOR)
];
define operator_classes=[
zz(COMMA)
yy([,])
xx(OR, or_X)
yy([∨], or_X)
xx(AND, and_X)
yy([∧], and_X)
xx(NOT, not_X)
yy([¬], not_X)
zz(ORDER)
yy([=], seq_X)
yy([≠], sne_X)
yy([>], sgt_X)
yy([<], slt_X)
yy([≥], sge_X)
yy([≤], sle_X)
zz(ABS)
yy([|])
yy(VVVTRANS)
zz(ADD)
yy([+], plus_X)
yy([-], minus_X)
zz(MULT)
yy([.], vdot_X)
yy([*], times_X)
yy([/], sdiv_X)
yy([⊗], vcross_X)
yy(WRT, wrt_X)
yy(VVROT, vvrot_X)
zz(TRANS)
yy(→, →_X)
yy([↑], stos_X)
zz(VECTOR)
yy([#],, nomv_X)
yy(ORIENT, orient_X)
yy(UNIT, uvect_X)
yy(AXIS, axis_X)
yy(POS, pos_X)
yy(INV, rinv_X)
zz(CLOSE_PAREN)
yy([)])
];
define require_definitions=[
xx(SOURCE_FILE)
xx(DELIMITERS)
xx(UNSTACK_DELIMITERS)
xx(REPLACE_DELIMITERS)
xx(MESSAGE)
xx(ERROR_MODES)
xx(COMPILER_SWITCHES)
xx(COMMENT_DELIMITERS)
xx(BAIL)
];
define move_definitions=[
xx(VIA)
xx(WITH)
xx(APPROACH)
yy(ARRIVAL)
yy(DEPARTURE)
xx(WOBBLE)
xx(DIRECTLY)
];
! All reserved word class id's have a postfix of "_RES". The fact that the parser
groups clases together is reflected by the definition of id's with "_beg" and
"_end" postfixes. The code demands that misc_RES be 0;
define
sex_RES =-2,
brace_RES =-1,
misc_RES =0,
cm_RES =0,
reserved_X_count=0,
statement_beg =reserved_X_count+1;
statement_definitions;
define
statement_end =reserved_X_count,
operator_beg =reserved_X_count+1;
operator_classes;
define
operator_end =reserved_X_count,
move_beg =reserved_X_count+1;
move_definitions;
define
move_end =reserved_X_count,
require_beg =reserved_X_count+1;
require_definitions;
define
require_end =reserved_X_count+1;
XX(METRIC) ! TIME, DISTANCE, etc.;
indices(require_definitions, _X);
indices(move_definitions, _X);
! brace, condition_monitor, dimension, misc reserved word definitions;
define brace_definitions=[
zz(BRACE)
yy([}])
yy([{])
];
define cm_definitions=[
zz(cm)
qq(nil)
yy(FORCE, force_cm)
yy(TORQUE, torque_cm)
yy(DURATION, duration_cm)
yy(TEMPERATURE)
yy(SQUEEZE)
];
define metric_definitions=[
zz(METRIC)
qq(nil)
yy(DISTANCE, distance_METRIC)
yy(TIME, time_METRIC)
! yy(MASS, mass_METRIC) ;
yy(ANGLE, angle_METRIC)
yy(FORCE, force_metric)
];
define misc_definitions=[
zz(MISC)
yy([?])
yy(ABS)
yy(TO)
yy(TRACING)
yy(WHERE)
yy(THEN)
yy(DO)
yy(FORM)
yy(AT)
yy(BY)
yy(CHANGING)
yy(ALSO)
yy(DONT)
yy(ONLY)
yy(RIGIDLY)
yy(NONRIGIDLY)
yy(STEP)
yy(UNTIL)
yy(ELSE)
];
redefine zz(str)=[];
redefine qq(str)=[
redefine qq_temp=[xx(str)];
qq_temp;];
redefine yy(str,str2)=[
redefine yy_temp=[xx(str)];
yy_temp;];
indices(metric_definitions, _METRIC);
define
metric_max =xxcount-1;
indices(cm_definitions, _CM);
EVALdefine basic_dimensions=[
redefine zz(str,str2)=[];
redefine qq(str,str2)=[];
redefine yy(str,str2)=[xx(str)];
metric_definitions
];
! dec_name, declaration names for input and output;
! don't juggle the order of these definitions, because the parse will cease to
function;
define dec_name_definitions=[
xx(SCALAR, SVAR)
xx(VECTOR, VVAR)
xx(ROT, RVAR)
xx(FRAME, FVAR)
xx(PLANE, PVAR)
xx(TRANS, TVAR)
xx(EVENT, EVAR)
xx(ATOM, ATOM)
xx(WORLD, WVAR)
xx(CM_LABEL, OMNLAB)
xx(CLC_LABEL, CLCLAB)
xx(CH_LABEL, CHGLAB)
xx(LABEL, STMLAB)
];
! data types;
DEFINE
string_VALUE =-2,
form_VALUE =-1,
boole_VALUE =0; ! others follow directly;
define
dec_name_count=0;
redefine xx(in, out)=[
redefine dec_name_count=dec_name_count+1;
redefine xx_temp="define in" & "_VALUE=" & cvms(dec_name_count);
xx_temp;];
dec_name_definitions;
define frame_exp_VALUE=trans_VALUE; ! COERCION DICTATES THAT THESE BE THE SAME;
redefine xx(in, out)=["out",];
preload_array(
dec_name, dec_name_definitions, string, 1, dec_name_count);
! operators;
! ********** WARNING!!!!! **********
keep all entries marked TRUE contiguous
don't disturb the order of this table ;
define operator_definitions=[
XX(NOT, 1, FALSE, boole, boole, ignore)
XX(AND, 2, FALSE, boole, boole, ignore)
XX(OR, 2, FALSE, boole, boole, ignore)
XX(SEQ, 2, FALSE, boole, scalar, ignore)
XX(SNE, 2, FALSE, boole, scalar, ignore)
XX(SGT, 2, FALSE, boole, scalar, ignore)
XX(SLT, 2, FALSE, boole, scalar, ignore)
XX(SGE, 2, FALSE, boole, scalar, ignore)
XX(SLE, 2, FALSE, boole, scalar, ignore)
XX(UVECT, 1, FALSE, vector, vector, same)
XX(AXIS, 1, FALSE, vector, rot, ignore)
XX(POS, 1, FALSE, vector, trans, ignore)
XX(ORIENT, 1, FALSE, rot, trans, ignore)
XX(TMAKE, 2, TRUE, trans, boole, ignore)
XX(VMAKE, 3, TRUE, vector, scalar, ignore)
XX(FMAKE, 2, TRUE, trans, boole, ignore)
XX(VVTRANS, 3, TRUE, trans, scalar, ignore)
! XX(SNEG, 1, TRUE, scalar, scalar, same) ;
XX(RINV, 1, TRUE, scalar, scalar, inverse)
XX(SABS, 1, TRUE, scalar, scalar, same)
XX([+], 2, TRUE, scalar, scalar, check, PLUS)
XX([-], 2, TRUE, scalar, scalar, check, MINUS)
XX([*], 2, TRUE, scalar, scalar, multiply, TIMES)
XX(WRT, 2, TRUE, scalar, scalar, multiply)
XX(ROT, 2, TRUE, vector, boole, ignore)
XX(→, 2, TRUE, trans, boole, divide)
XX(VDOT, 2, FALSE, scalar, vector, multiply)
XX(ANGLE, 2, FALSE, scalar, vector, ignore)
XX(VCROSS, 2, FALSE, vector, vector, multiply)
XX(VVROT, 2, FALSE, rot, vector, ignore)
XX(SDIV, 2, FALSE, scalar, scalar, divide)
XX(STOS, 2, FALSE, scalar, scalar, ignore)
XX(NOMV, 1, FALSE, form, form, same)
];
define
first_true_op=-1,
op_count=0;
redefine xx(str1, i1, boole, i2, i3, i4, str2)=[
redefine op_count=op_count+1;
ifc "str2"=null
thenc redefine xxtemp=[define str1] & "_X=op_count";
elsec redefine xxtemp=[define str2] & "_X=op_count";
endc
xxtemp;
ifc first_true_op<0 and boole
thenc redefine first_true_op=op_count; endc];
operator_definitions;
define zap_op(name, type, arg, postfix)=[
ifc "postfix"=null
thenc redefine xx(str1, i1, boole, i2, i3, i4, str2)=[arg,];
elsec redefine xx(str1, i1, boole, i2, i3, i4, str2)=
[arg]&[postfix,];
endc
preload_array(name, operator_definitions, type, 1, op_count)];
zap_op(
op_array, string, "str1");
zap_op(
op_num, integer, i1);
zap_op(
op_bool, boolean, boole);
zap_op(
result_type, integer, i2, _VALUE);
zap_op(
type_of_args, integer, i3, _VALUE);
! specifies how to work out new DIMENSION of argument ;
define
ignore_dimen =0,
same_dimen =1,
inverse_dimen =2,
check_dimen =3,
multiply_dimen =4,
divide_dimen =5;
zap_op(
dimen_changes, integer, i4, _dimen);
! reserved_words;
define reserved_definitions=[
brace_definitions
cm_definitions
statement_definitions
operator_classes
require_definitions
move_definitions
misc_definitions
sex_definitions
];
define
reserved_count=0;
redefine zz(name)= [];
redefine qq(name)= [];
redefine xx(name)=[
redefine reserved_count=reserved_count+1;];
redefine yy(name, special)=[
redefine reserved_count=reserved_count+1;];
reserved_definitions;
redefine xx(name)=["name",];
redefine yy(name,special)=["name",];
preload_array(
reserved_words, reserved_definitions, string, 1, reserved_count);
redefine zz(name)=[
redefine class=["name"];
];
redefine xx(name)=[
redefine xxtemp=[name] & "_RES";
redefine class=["name"];
xxtemp,];
redefine yy(name,special)=[
redefine yytemp= class &"_RES";
yytemp,];
preload_array(
reserved_class, reserved_definitions, integer, 1, reserved_count);
redefine xx(name)=[0,];
redefine yy(name, special)=[
ifc "special"=null thenc 0 elsec special endc,];
preload_array(
reserved_special, reserved_definitions, integer, 1, reserved_count);
whilec [reserved_count > 9*reserved_hasher/10] doc
[require "
RESERVED TABLE NOT BIG ENOUGH, WILL DOUBLE IT.
" message ;
redefine reserved_hasher=reserved_hasher+reserved_hasher;]
endc
string array
reserved[0:reserved_hasher-1];
integer array
com_type[0:reserved_hasher-1];
! init_reserved;
forward SIMPLE INTEGER PROCEDURE HASH(STRING S;INTEGER MAX);
procedure init_reserved;
α string s; integer i, k;
boolean procedure find_sym(string s; reference integer k);
α string probe;
k ← hash(s, reserved_hasher);
while (probe ← reserved[k])≠null do
if equ(s, probe) then return(true) else k ← (k+1) mod reserved_hasher;
return(false);
β;
arrclr(reserved); arrclr(com_type);
for i ← 1 step 1 until reserved_count do
if find_sym(reserved_words[i], k)
then α if reserved_class[i] ≠ SEX_RES then
outstr(reserved_words[i] & " doubly defined!" & crlf);
β
else
α
reserved[k] ← reserved_words[i];
com_type[k] ← reserved_class[i]+reserved_special[i]*reserved_hasher;
β;
require "<><>" delimiters;
s ← decipher_compiletime();
require unstack_delimiters;
outstr("COMPILED "&s&crlf);
β;
require init_reserved initialization [0];
! predefined constants;
define constant_definitions=[
XX(GARB_ID, scalar, nil) ! do not move this entry;
XX(PI, scalar, nil)
XX(π, scalar,nil)
XX(INCH, scalar, distance)
XX(INCHES, scalar, distance)
XX(CM, scalar, distance)
XX(SEC, scalar, time)
XX(SECONDS, scalar, time)
! XX(GM_MASS, scalar, mass) ;
XX(DEG, scalar, angle)
XX(DEGREES, scalar, angle)
XX(RADIANS, scalar, angle)
XX(GM, scalar, force)
XX(OZ, scalar, force)
XX(LBS, scalar, force)
XX(OUNCES, scalar, force)
XX(XHAT, vector, nil)
XX(YHAT, vector, nil)
XX(ZHAT, vector, nil)
XX(NILVECT, vector, nil)
XX(NILROTN, rot, angle)
XX(NILTRANS, trans, nil)
XX(STATION, trans, distance)
XX(YPARK, trans, distance)
XX(BPARK, trans, distance)
XX(YARM, trans, distance)
XX(BARM, trans, distance)
XX(YHAND, scalar, distance)
XX(BHAND, scalar, distance)
XX(TRUE, boole, nil)
XX(FALSE, boole, nil)
XX(CRLF, string, nil)
];
define
const_count = 0;
redefine xx(str, i1, i2)=[redefine const_count = const_count+1;];
constant_definitions;
define zap_const(name, type, arg, postfix)=[
ifc "postfix"=null
thenc redefine xx(str, i1, i2)=[arg,];
elsec redefine xx(str, i1, i2)=[arg] & [postfix,];
endc
preload_array(name, constant_definitions, type, 1, const_count)];
zap_const(
preconst, string, "str");
zap_const(
preconst_type, integer, i1, _VALUE);
zap_const(
pre_dimens, integer, i2, _METRIC);
! predefined macros;
define macro_definitions=[
! XX(DIRECTLY, [ WITH APPROACH = NILDEPROACH WITH DEPARTURE = NILDEPROACH]);
XX(NON_BEGINNER, [BEGIN REQUIRE ERROR_MODES ""F"";])
XX(CAUTIOUS, [ SPEED_FACTOR ← 2.0])
XX(SLOW, [ SPEED_FACTOR ← 3.0])
XX(CAUTIOUSLY, [ WITH SPEED_FACTOR = 2.0])
XX(SLOWLY, [ WITH SPEED_FACTOR = 3.0])
XX(SETUP_BARMF, [ FRAME BARMF;
AFFIX BARMF TO BARM AT TRANS(ROT(XHAT,180*DEG),NILVECT*INCHES) RIGIDLY; ])
];
! compiler switches and control tables;
! As the AL compile time system runs, several intermediate files are created
and destroyed. The default extensions of these files are listed below.
.AL user the ALGOL like AL source language
.LOG user file of errors detected by the PARSER
.SEX AL s-expression version of AL source code
.ALP (.AL0) ALC pseudo code
.ALT (.AL1) ALC trajectory file
.ALV (.AL2) ALC constants and variable definitions for pseudo code
.ALS (.AL3) ALC symbol table usable by the PDP-11 runtime system
.ALL ALC hybrid s-expression/real AL listing
.LST PALX PDP-11 assembly code listing
.BIN PALX PDP-11 binary file loaded by 11TTY
.DMP 11TTY PDP-11 core image
;
! compiler switches;
define compiler_switches=[
xx(K, false) ! keep extraneous intermediate files: .ALP, .ALV, .ALT;
xx(S, false) ! inhibit the deletion of the .SEX file;
xx(L, false) ! generate a PALX assembly listing;
xx(B, false) ! run BAIL immediately after scanning the command line;
xx(E, false) ! load the .BIN file into the PDP-11;
];
indices(compiler_switches, _X);
define
switch_max =xxcount-1;
redefine xx(name, default)=["name",]; preload_array(
switch_name, compiler_switches, string, 0, switch_max+1);
redefine xx(name, default)=[default,]; preload_array(
switch_default, compiler_switches, boolean, 0, switch_max+1);
boolean array
switch_setting[0:switch_max];
procedure preset_switches;
α integer i;
for i ← 0 step 1 until switch_max do switch_setting[i] ← switch_default[i];
β;
require preset_switches initialization[0];
! hash, declaration of debugging variables, start of hidden_parse;
SIMPLE INTEGER PROCEDURE HASH(STRING S;INTEGER MAX);
α INTEGER I,TOT,C;
C←I←1; TOT←0;
WHILE I≠0 DO TOT←TOT+(C←C+1)*(I←LOP(S));
RETURN(TOT MOD MAX);
β;
ifc debug_compile thenc ! some variables that can be used for debugging;
require "BREAK.HDR[1,PJ]" source_file;
RPTR(any_class)
__r0, __r1, __r2, __r3, __r4, __r5, __r6, __r7, __r8, __r9;
string
__s0, __s1, __s2, __s3, __s4, __s5, __s6, __s7, __s8, __s9;
integer
__i0, __i1, __i2, __i3, __i4, __i5, __i6, __i7, __i8, __i9;
real
__x0, __x1, __x2, __x3, __x4, __x5, __x6, __x7, __x8, __x9;
procedure debug_init;
α
__r0 ← __r1 ← __r2 ← __r3 ← __r4 ← __r5 ← __r6 ← __r7 ← __r8 ← __r9 ← null_record;
__s0 ← __s1 ← __s2 ← __s3 ← __s4 ← __s5 ← __s6 ← __s7 ← __s8 ← __s9 ← null;
__i0 ← __i1 ← __i2 ← __i3 ← __i4 ← __i5 ← __i6 ← __i7 ← __i8 ← __i9 ← 0;
__x0 ← __x1 ← __x2 ← __x3 ← __x4 ← __x5 ← __x6 ← __x7 ← __x8 ← __x9 ← 0.0;
β;
require debug_init initialization[0];
endc
! The following (making all of parse a recursive procedure) is a hack to get the
restart option to work properly. As soon as a better way is found of
making sure everything gets reinitialized properly, this should be taken
out;
recursive procedure hidden_parse;
α "hidden_parse"
! ---- DECLARATIONS ----;
external integer
rpgsw;
RPTR(file)
AL_file, ! AL source file;
SEX_file, ! s-expression file;
BIN_file, ! PALX binary file;
ALL_file, ! ALC listing file;
LOG_file, ! LOG listing file;
PRESENT_file; ! Present file;
BOOLEAN
DISK, ! TRUE IF INPUT IS COMING FROM DISK;
AUTO_PROCEED, ! TRUE IF AUTO_PROCEED SWITCH IS ON FOR ERROR RECOVERY;
LOGGING, ! TRUE IF LOGGING WANTED;
COMPILE_LOGGING, ! TRUE IF LOGGING WANTED THROUGH REQUIRE STATEMENT;
LOG_FILE_OPEN,
STRICT_DIMEN_CHECK;
STRING
cmd_line,
INFILE,
OUTFILE, ! INPUT,OUTPUT & LOG FILES;
LOGFILE;
INTEGER
CHANIN,
CHANOUT,
CHANTTYO,
CHANLOG;
STRING
INSTRING, ! INPUT STRING;
TABLE1; ! BREAK TABLES;
! GET_TOKEN VARIABLES;
REAL
REALNUM;
INTEGER
TYPE_OF_RES_WORD, ! TYPE PULLED OFF OF COM_TYPE;
SPECIAL_INFO, ! INFO PASSED FROM SCANNER TO PARSER - DEPENDS ON TYPE;
ID_TYPE,
BLOCK_LEVEL_OF_DEFN,
RESERVED_TOKEN_PTR,
TYPE_OF_TOKEN;
define
special_token =-1,
undeclared_token=0,
id_token =1,
numeric_token =2,
string_token =3,
macro_token =4,
macro_body_token=5,
metric_token =6,
reserved_token =7;
STRING PROCEDURE TOKEN_TYPE_TRANSFORM;
α string s1;
s1← CASE TYPE_OF_TOKEN OF ( "undeclared","id","numeric",
"string","macro","macro_body","metric","reserved");
return(s1&"_type");
β;
STRING PROCEDURE ID_TYPE_TRANSFORM;
α string s1;
s1← CASE (ID_TYPE + 2 )OF ("string","form","boole","scalar",
"vector","rot","frame","plane","trans","event","atom",
"world","on_label","calculator_label",
"changer_label","statement_label");
return(s1&"_type");
β;
STRING
TOKEN,
TOKEN_FRONT;
RPTR(ANY_CLASS)
TOKEN_PTR;
! END GET_TOKEN VARIABLES;
integer
word_R_break, ! break tables;
non_blank_break,
word_S_break,
close_brace_break,
non_digit_break,
quote_break,
macro_delimiter_break,
semicolon_A_break,
cr_break,
paren_cr_break,
lf_ff_break,
semicolon_R_break,
omit_break,
tty_input_break;
STRING
CURRENT_FRAME; ! TOKEN OF THE CURRENT FRAME - DEFAULT SET TO "YARM";
INTEGER
SPACING; ! SPACING FOR OUTPUT;
BOOLEAN
REJECT; ! TRUE WHEN THE LAST TOKEN IS REJECTED BY THE CALLING PROC;
INTEGER
DEC_NUM, ! THE NUMBER OF DECLARATIONS IN THE CURRENT BLOCK;
MACRO_DEC_NUM, ! THE NUMBER OF MACROS IN CURRENT BLOCK;
DIMEN_DEC_NUM; ! THE NUMBER OF DIMENSIONS IN THE CURRENT BLOCK;
STRING
OUTEXPR; ! FOR THE CONSTRUCTION OF THE STRING FOR EXPRESSIONS;
STRING
OPEN_BRACE;
INTEGER
CHECK_TYPE_VAR; ! RETURNS TYPE OF ID FROM CHECK_ENTRY;
STRING
MACRO_STRING;
! ERROR VARIABLES;
BOOLEAN
INSIDE_MACRO_DEFINITION,
INSIDE_DECLARE_P,
INSIDE_CONDITION_MONITOR,
INSIDE_STRING_DECLARATION,
INITIALIZE, ! INITIALIZATION PROCESS;
CAN_MODIFY, ! FOR ERRORS;
PATCH_CODE, ! TO PATCH CODE;
MODIFIED,
BACKUP_MODIFY,
BACKUP_MODIFIED,
PROMPT_FOR_MODIFIABLE_ERROR_ONLY;
INTEGER
NUM_OF_ERRORS,
INSIDE_STATEMENT,
NUM_OF_ERRORS_FLUSHED,
NUM_OF_ERRORS_MODIFIED;
STRING
BACKUP_ERROR_BUFFER,
ERROR_BUFFER;
! END ERROR VARIABLES;
INTEGER
RUNTIME;
! record declarations;
RCLASS
PARAM_LIST(
STRING
ID,
USER_ID;
RPTR(PARAM_LIST)
NEXT
);
RCLASS
MACRO_LIST(
STRING
VALUE, ! ACTUAL MACRO body;
ID,
DELIMITERS;
INTEGER
NUM; ! NUMBER OF PARAMETERS;
RPTR(MACRO_LIST)
NEXT, ! POINTS TO NEXT MACRO WHICH HASHES TO THE SAME ENTRY;
LAST, ! BACK POINTER IN THE SAME LIST;
LINK; ! USED ONLY FOR PARAMETER EXPANSION, POINTS TO THE
PARAMETER DEFINED JUST BEFORE THIS ONE;
RPTR(PARAM_LIST)
PARAMS;
INTEGER
BLOCK_LEVEL_OF_DEFN
);
RPTR(MACRO_LIST)
TOP_PARAM,
current_macro,
TOP_MACRO,
CUR_MACRO;
RPTR(MACRO_LIST) ARRAY
MACRO_TABLE[0:macro_hasher];
RCLASS
DELIMITER_LIST(
STRING
D1,
D2;
RPTR(DELIMITER_LIST)
NEXT
);
RPTR(DELIMITER_LIST)
TOP_DELIMITERS;
RCLASS
MACRO_STACK(
RPTR(MACRO_LIST)
LIST_PTR;
RPTR(MACRO_STACK)
STACK_LINK
);
RPTR(MACRO_STACK)
MACRO_STACK_TOP,
MACRO_ST2;
RCLASS
MACRO_CONCATENATE_LIST(
RPTR(MACRO_LIST)
MACRO_PTR;
RPTR(MACRO_CONCATENATE_LIST)
NEXT
);
RPTR(MACRO_CONCATENATE_LIST)
MACRO_CON_HEAD;
RCLASS
DIMENS_EXPONENT(
STRING
NAME;
INTEGER
DISTANCE,
TIME, ! GIVES EXPONENTS OF VARIOUS COEFFICIENTS;
MASS,
ANGLE,
FORCE;
RPTR(DIMENS_EXPONENT)
NEXT,
LAST;
INTEGER
BLOCK_LEVEL_OF_DEFN
);
RPTR(DIMENS_EXPONENT)
NIL_DIMENS,
DISTANCE_DIMENS,
TIME_DIMENS,
! MASS_DIMENS;
ANGLE_DIMENS,
FORCE_DIMENS,
TORQUE_DIMENS,
VELOCITY_DIMENS,
ANGULAR_VELOCITY_DIMENS,
TOP_DIMENS, ! POINTS TO TOP MACRO IN THIS BLOCK;
EXP_DIMENS;
RPTR(DIMENS_EXPONENT) ARRAY
DIMENS_TABLE[0:metric_hasher],
D_TABLE[0:metric_max];
RCLASS
ID_LIST(
STRING
NAME,
BODY;
INTEGER
FLAGS,
TYPE;
RPTR(ID_LIST)
NEXT, ! POINTS TO NEXT ID WHICH HASHES TO THE SAME ENTRY;
LAST; ! POINTS TO THE ID DEFINED JUST BEFORE THIS ONE;
RPTR(DIMENS_EXPONENT)
DIMEN;
INTEGER
BLOCK_LEVEL_OF_DEFN
);
RPTR(ID_LIST) ARRAY
SYMBOL_TABLE[0:id_hasher];
RPTR(ID_LIST)
TOP_ID;
RCLASS
EXPR(
INTEGER
TYPE;
STRING
OP,
ID;
RPTR(DIMENS_EXPONENT)
DIMEN;
RPTR(ANY_CLASS)
PARTS
);
RPTR(EXPR)
EXP1,
EXP2,
EXP3;
RCLASS
EXPR_LIST(
RPTR(EXPR)
EXP;
RPTR(EXPR_LIST)
NEXT
);
RPTR(EXPR_LIST)
EXPRS,
EXPRSAVE;
RCLASS
OP_LIST(
RPTR(OP_LIST)
NEXT;
INTEGER
PRIORITY,
OP,
NUM_OF_ARGS,
COUNT;
BOOLEAN
ARG_DEP,
FUNC
);
RPTR(OP_LIST)
OPS,
OPSAVE;
RCLASS
SOURCE_LIST(
INTEGER
CHAN, ! i/o CHANNEL NUMBER OF input, -1 if from macro;
NUM, ! NUMBER OF PARAMETERS IN THE CURRENT MACRO;
PN,
LN; ! PAGE AND LINE NUMBER OF THE PUSHED FILE;
STRING
CUR_STRING, ! curline WHEN PUSHED;
CUR_STRINGR, ! curliner WHEN PUSHED;
FILE_NAME, ! NAME OF THE INPUT FILE WHEN PUSHED;
MACRO_STRING;
RPTR(SOURCE_LIST)
NEXT;
RPTR(MACRO_STACK)
MACRO_STACK_TOP;
RPTR(MACRO_LIST)
CUR_MACRO;
RPTR(FILE)
FILE_PTR;
INTEGER
CHANTTYO
);
RPTR(SOURCE_LIST)
TOP_SOURCE;
! other declarations;
INTEGER
EXP_TYPE; ! TYPE OF EXPRESSION FOUND BY P_EXP;
BOOLEAN
PLAN_STATEMENT; ! TRUE IF CURRENT STATMENT IS PREFIXED BY PLAN;
STRING
CHANGER_HEAD; ! NON NULL IF PARSING A STATEMENT INSDIDE A CHANGER;
INTEGER
T_COUNT, ! COUNTER FOR PRODUCING UNIQUE ID'S;
S_COUNT; ! COUNTER FOR PRODUCING UNIQUE SCALARS;
BOOLEAN
NO_OP_SO_FAR,
OP_EXPECTED; ! TRUE WHEN P_EXP EXPECTS AN OPERATION;
INTEGER
DELIMITER_1, ! non-zero only while defining macro;
DELIMITER_2; ! HEAD AND TAIL DELIMITER OF macro bodies;
INTEGER
MAC_NUM; ! NUMBER OF PARAMS IN THE CURRENT MACRO EXPANSION;
INTEGER
BLOCK_LEVEL;
! GARBAGE DECLARATIONS (VERY LOCAL);
BOOLEAN
T,
EOF;
INTEGER
COUNT,
I,
N,
BRCHAR;
STRING
GARB;
INTEGER
LINENUM,
PAGENUM,
SOSNUM,
typed_page_num, ! on tty;
sourcelvl;
STRING
CURLINER,
CURLINE;
! error, error_recovery, error_reject, print, file_indent;
FORWARD RECURSIVE PROCEDURE P_STATEMENT;
forward procedure add_to_table1(string s);
FORWARD RECURSIVE PROCEDURE GET_TOKEN;
FORWARD PROCEDURE OPEN_LOGGING_FILE;
forward RPTR (ANY_CLASS) PROCEDURE CHECK_ENTRY (STRING S; INTEGER TABLE_TYPE);
forward RPTR (ANY_CLASS) PROCEDURE INSERT_ENTRY (STRING S;
INTEGER TABLE_TYPE; RPTR(ANY_CLASS) RR1(NULL_RECORD));
forward boolean procedure got_output(RPTR(file) F);
RPTR(ANY_CLASS) PROCEDURE ERROR(INTEGER I;STRING S);
! I don't understand the error number stuff. All errors numbered 200
have been added by me and can be arbitrarily reassigned.
PJ 8/30/76;
α INTEGER L1,L2; BOOLEAN PROCEED; INTEGER COMMAND_CHAR; BOOLEAN TERSE;
RPTR(ANY_CLASS) PROCEDURE ERROR_RECOVERY(INTEGER I);
IF I=13 THEN α RPTR(ID_LIST)D1;
OUTSTR(CRLF& "Continue will declare it internally");
D1←INSERT_ENTRY(TOKEN,ID_TYPE_TABLE);
ID_LIST:TYPE[D1]←TRANS_VALUE;
ID_LIST:BLOCK_LEVEL_OF_DEFN[D1]←BLOCK_LEVEL;
RETURN(D1);
β
ELSE
IF I=55 THEN α string s; s←null;
WHILE LENGTH(S)=0 AND ¬AUTO_PROCEED DO α
OUTSTR(CRLF& "Type in correct file"&crlf& "*");
s←inchwl; PROCEED←TRUE;
if length(s)≠0 then infile←s;
β;
RETURN(NULL_RECORD);
β
ELSE
RETURN(NULL_RECORD);
RPTR(ANY_CLASS) C1;
string source_pos;
STRING LINE,LINER;
source_pos←"File "& INFILE& ", Page "& CVS(PAGENUM+1)& ", Line "& CVS(LINENUM);
LINE←CURLINE; LINER←CURLINER;
IF CHANIN≤-1 THEN α ! SUBSTITUTE DUMMY PARAMETERS OF MACRO FOR REAL THING;
INTEGER I1,PARAM_COUNT;
source_pos← "At "&source_pos&crlf&"inside Macro "¯o_list:id[current_macro];
if liner=space then liner←liner[2 to ∞];
IF (PARAM_COUNT←SOURCE_LIST:NUM[TOP_SOURCE]) > 0
THEN α
string array param_id,param_arg[1:param_count];
RPTR(param_list) param_ptr;
integer l1,l2,temp;
string t;
string procedure subst(string old_string);
α string t,t1,old;
integer brchar,i1;
old←old_string;
t←scan(old,temp,brchar);
while brchar≠0 do
α t1←old[1 to l1];
old←old[l2 to ∞];
for i1←1 step 1 until param_count do
if equ(t1,param_arg[i1])
then t←t¶m_id[i1];
t←t&scan(old,temp,brchar);
β;
return(t);
β;
param_ptr←macro_list:params[current_macro];
source_pos←source_pos&"(";
for i1←1 step 1 until param_count do
α param_arg[i1]←param_list:id[param_ptr];
param_id[i1]←param_list:user_id[param_ptr];
param_ptr←param_list:next[param_ptr];
source_pos←source_pos¶m_id[i1]&",";
β;
l1←length(source_pos);
source_pos←source_pos[1 to l1-1]&")"&crlf;
l2←(l1←length(param_arg[1]))+1;
t←param_arg[1][1 for 1];
setbreak(temp←getbreak,t,null,"INR");
line←subst(line);
liner←subst(liner);
RELBREAK(TEMP);
β;
β;
WHILE EQU(LINE[1 TO 1], lf) DO GARB←LOP(LINE);
L1←LENGTH(LINER); L2←LENGTH(LINE)-L1; PROCEED←AUTO_PROCEED;
IF ¬PROMPT_FOR_MODIFIABLE_ERROR_ONLY OR CAN_MODIFY
then α
IF CAN_MODIFY THEN PROCEED←FALSE;
ifc debug_compile thenc
OUTSTR(crlf & "ERROR TYPE " & CVS(I));
endc
OUTSTR(crlf & S & crlf
& source_pos & crlf & LINE[1 TO L2] & lf & LINER & crlf);
β
ELSE IF PROMPT_FOR_MODIFIABLE_ERROR_ONLY THEN PROCEED←TRUE;
C1←ERROR_RECOVERY(I);
IF ¬LOGGING THEN IF COMPILE_LOGGING THEN OPEN_LOGGING_FILE;
IF LOGGING THEN
OUT(CHANLOG,crlf & "ERROR TYPE " & CVS(I) & crlf & S & crlf
& source_pos & crlf & LINE[1 TO L2] & lf & LINER & crlf);
WHILE ¬PROCEED DO
α
CLRBUF; OUTSTR("$"); DO COMMAND_CHAR←INCHRS UNTIL COMMAND_CHAR<0;
COMMAND_CHAR←INCHRW;
CASE COMMAND_CHAR OF
α
["B"] α
OUTSTR("ail" & crlf);
IFC debug_compile
THENC BAIL
ELSEC OUTSTR("Sorry, Bail not loaded." & crlf)
ENDC;
β;
[cr] α CLRBUF; PROCEED←TRUE; β;
["C"] α OUTSTR("ontinue with default recovery"); PROCEED←TRUE; β;
[lf] α PROCEED←TRUE; AUTO_PROCEED←TRUE; β;
["A"] α OUTSTR("utomatic continuation");
IF LOGGING THEN OUTSTR(" and logging");
OUTSTR(".");
PROCEED←TRUE; AUTO_PROCEED←TRUE;
β;
["E"] α OUTSTR("dit" & crlf);
CLOSO(CHANLOG);CLOSO(CHANOUT);
EDFILE(INFILE,LINENUM,PAGENUM+1,0);
β;
IFC DEBUG_COMPILE THENC
["∂"] α
OUTSTR(" special debugger"&CRLF); ! for quick debugging without invoking BAIL;
OUTSTR("TOKEN= "&TOKEN&" ; TYPE_OF_TOKEN = "&TOKEN_TYPE_TRANSFORM&CRLF);
IF INSIDE_STATEMENT ≥0 THEN OUTSTR("; INSIDE STATEMENT "&RESERVED[INSIDE_STATEMENT]&CRLF);
IF TYPE_OF_TOKEN=ID_TOKEN THEN OUTSTR("; ID_TYPE= "& ID_TYPE_TRANSFORM&CRLF);
OUTSTR("CURLINER = " & CURLINER & CRLF & "CURLINE = "& CURLINE &CRLF);
β;
["ε"] α STRING SS;
OUTSTR(" special debugger"&crlf); ! for quick debugging ;
outstr("number of errors = "&CVS(NUM_OF_ERRORS)&CRLF&
"number of errors modified = "&cvs(NUM_OF_ERRORS_MODIFIED)&CRLF&
"number of errors flushed = "&cvs(NUM_OF_ERRORS_FLUSHED)&CRLF);
OUTSTR("RESET THESE COUNTERS?");
IF (SS←INCHRW)="Y" THEN NUM_OF_ERRORS←NUM_OF_ERRORS_MODIFIED←NUM_OF_ERRORS_MODIFIED←0;
β;
ENDC
["R"] α
OUTSTR("estart"); CURLINE←CURLINER←null;
USERERR(0,1,NULL,"S"); ! THIS IS A HACK AND SHOULD BE CHANGED
AS SOON AS POSSIBLE;
β;
["X"] α OUTSTR("it" & crlf);
USERERR(0,1,NULL,"X"); ! DITTO ABOVE COMMENT;
β;
["M"] IF CAN_MODIFY THEN
α
OUTSTR("odify the following line"&CRLF);
CLRBUF;
LODED(ERROR_BUFFER);
ERROR_BUFFER←INCHWL;
MODIFIED←PROCEED←TRUE;
CAN_MODIFY←FALSE;
NUM_OF_ERRORS_MODIFIED←NUM_OF_ERRORS_MODIFIED+1;
β
ELSE OUTSTR("odify - ******* - sorry, non-modifiable error"&CRLF);
["T"] α OUTSTR("erse" & crlf); TERSE←TRUE; β;
["V"] α OUTSTR("erbose" & crlf); TERSE←FALSE; β;
["P"] IF PATCH_CODE THEN
α
OUTSTR("atch source code; modify following line"&CRLF);
CLRBUF;
LODED(LINER);
CURLINER←INCHWL;
CURLINE←LINE[1 TO L2] & CURLINER;
PATCH_CODE←FALSE;
PROCEED←TRUE;
NUM_OF_ERRORS_MODIFIED←NUM_OF_ERRORS_MODIFIED+1;
β
ELSE OUTSTR("atch - ***** sorry, non-patchable error *****"&CRLF);
["G"] IF BACKUP_MODIFY THEN
α OUTSTR(" Modify the following line" & CRLF);
CLRBUF;
LODED(BACKUP_ERROR_BUFFER);
BACKUP_ERROR_BUFFER←INCHWL;
BACKUP_MODIFIED←PROCEED←TRUE;
BACKUP_MODIFY←FALSE;
NUM_OF_ERRORS_MODIFIED←NUM_OF_ERRORS_MODIFIED+1;
β
ELSE IF CAN_MODIFY
THEN OUTSTR(" Global Modify - ****** Sorry, only local modify using M "&CRLF)
ELSE OUTSTR(" Modify - ******** - sorry, non-modifiable error"&CRLF);
["?"] IF ¬TERSE THEN
α
OUTSTR("Reply [CR] or ""C"" to continue," & crlf &
"[LF] or ""A"" to continue automatically," & crlf &
"""E"" to edit source file," & crlf &
"""R"" to restart," & crlf &
"""T"" for terse," & crlf &
"""V"" for verbose," & crlf &
"""X"" to exit");
IFC DEBUG_COMPILE THENC OUTSTR("," & crlf & """B"" to load Bail"); ENDC
IF ¬LOGGING THEN OUTSTR("," & crlf & """L"" for logging");
IF CAN_MODIFY THEN OUTSTR("," & crlf & """M"" for modify");
IF BACKUP_MODIFY THEN OUTSTR(","&crlf& """G"" for backup and modify");
IF PATCH_CODE THEN OUTSTR(","&crlf&"""P"" for patching source code");
OUTSTR("." & crlf);
β
ELSE OUTSTR("OPTIONS cr,lf,E,R,T,X,B,L,M,G, and V? for verbose"&CRLF);
["L"] IF ¬LOGGING THEN
α
OPEN_LOGGING_FILE;
OUT(CHANLOG,crlf & "ERROR TYPE " & CVS(I) & crlf & S & crlf
& source_pos & crlf & LINE[1 TO L2] & lf & LINER & crlf);
OUTSTR("ogging in file name " & LOGFILE & crlf );
β
ELSE OUTSTR("ogging already");
ELSE OUTSTR(" Unrecognized character; type ""?"" for allowable characters."&crlf)
β;
β;
IF I>0 THEN NUM_OF_ERRORS←NUM_OF_ERRORS+1;
RETURN(C1);
β;
RPTR(ANY_CLASS) PROCEDURE ERROR_REJECT(INTEGER I;STRING S);
α RPTR (ANY_CLASS)R1; R1←ERROR(I,S); REJECT←TRUE; RETURN(R1); β;
PROCEDURE PRINT(STRING S);
α
ifc debug_compile thenc
INTEGER I,J,K,L;
FOR I←1 STEP 1 UNTIL SPACING DO S←" "&S;
J←LENGTH(S);
WHILE J>80 DO
α;
K←80;
WHILE K≤J AND ¬EQU(S[K TO K]," ") DO K←K+1;
OUT(CHANOUT,S[1 TO K] & crlf);
S←S[K+1 TO J];
J←J-K;
β;
OUT(CHANOUT,S & crlf)
elsec
INTEGER I;
FOR I←1 STEP 1 UNTIL SPACING DO OUT(CHANOUT," ");
OUT(CHANOUT,S & crlf);
endc;
β;
procedure file_indent(integer i);
α
typed_page_num ← false;
outstr(" "[1 for 2*i]);
β;
PROCEDURE UNDEFINED_VAR(STRING VAR(NULL));
ERROR(0,"UNDEFINED VARIABLE "&VAR);
PROCEDURE UNAFFIXED_VAR(STRING VAR(NULL));
ERROR(0,"UNAFFIXED VARIABLE "&VAR);
! process_switches, got_input, got_output, open_logging_file, open_new_file,check_want_copy;
procedure process_switches(RPTR(file) F);
α RPTR(file_switch) swt;
swt ← file:switches[F];
while swt≠null_record do
α integer i;
for i ← 0 step 1 until switch_max do
if equ(file_switch:name[swt], switch_name[i])
then α switch_setting[i] ← true; done β;
if i > switch_max then
outstr("""" & file_switch:name[swt] & """ unknown switch"& crlf);
swt ← file_switch:next[swt]
β
β;
boolean procedure got_input(RPTR(file) F);
α
if file:chn[F] < 0 then file:chn[F] ← getchan;
if file:in_bfrs[F]≤0 then file:in_bfrs[F]←12;
open(file:chn[F], file:device[F], file:mode[F], file:in_bfrs[F],
file:out_bfrs[F], count, brchar, eof);
if eof then
α release(file:chn[F]); file:chn[F] ← -1; return(false) β;
infile ← make_file_name(F);
lookup(file:chn[F], infile, eof);
if eof ∧ length(file:ext[F])=0 ∧ length(file:def_ext[f])≠0 then
α "try default"
file:ext[F] ← file:def_ext[F];
infile ← make_file_name(F);
lookup(file:chn[F], infile, eof);
β "try default";
process_switches(F);
return(¬eof)
β;
boolean procedure got_output(RPTR(file) F);
α
string filename;
if file:chn[F] < 0 then file:chn[F] ← getchan;
open(file:chn[F], file:device[F], file:mode[F], file:in_bfrs[F],
file:out_bfrs[F], count, brchar, eof);
if eof then
α release(file:chn[F]); file:chn[F] ← -1; return(false) β;
if length(file:ext[F])=0 then file:ext[F] ← file:def_ext[F];
filename ← make_file_name(F);
enter(file:chn[F], filename, file:eof[F]); process_switches(F);
return(¬eof)
β;
procedure open_logging_file;
if ¬log_file_open then
α;
LOG_file←new_record(file);
copy_file_record(LOG_file,BIN_file);
file:mode[LOG_file]←0; file:in_bfrs[LOG_file]← 0;
file:out_bfrs[LOG_file]←12; file:ext[LOG_file] ← "LOG";
file:device[LOG_file]← "DSK";
file:name[LOG_file]←file:name[AL_file];
if ¬got_output(LOG_file) then
usererr(0, 1, "can't get output");
CHANLOG ← file:chn[LOG_file];
LOGFILE←make_file_name(LOG_file);
log_file_open←true;
logging←true;
β;
RPTR (file) procedure open_new_file(reference string s);
begin string word;
integer ignore_blanks_break,file_name_break,ppn_break,break;
RPTR(file)F;
integer procedure ignore_blanks(reference string s);
begin integer break; scan(s, ignore_blanks_break, break); return(break) end;
string procedure filwrd;
begin ignore_blanks(s); return(scan(s, file_name_break, break)) end;
setbreak(
ignore_blanks_break ← getbreak, space & tab, cr, "XRK");
setbreak(
file_name_break ← getbreak, "[:.," & lf, cr, "ISK");
setbreak(
ppn_break ← getbreak, "]" & lf, cr, "ISK");
F←new_record(file);
word ← filwrd; file:chn[F] ← -1; ! file has not been opened flag;
if break=":" then begin file:device[F] ← word; word ← filwrd end;
file:name[F] ← word;
if break="." then file:ext[F] ← filwrd;
if break="[" then
begin
ignore_blanks(s); file:ppn[F] ← "[" & scan(s, ppn_break, break) & "]";
if break="]" then begin ignore_blanks(s); break ← lop(s) end;
end;
if length(file:device[F])=0 then file:device[F] ← "DSK";
return(F);
end;
PROCEDURE CHECK_WANT_COPY;
IF ¬EQU(FILE:NAME[PRESENT_FILE],NULL)
THEN
α STRING SAVE;
! OUTSTR(CRLF&"Teletype input requested. Want to save on disk?(Y or N)");
! ALTERNATIVE METHOD SAVE←INCHRW;
SAVE←"Y";
IF SAVE = "Y"
THEN
α RPTR(FILE)F;
F←NEW_RECORD(FILE);
copy_file_RECORD(F,PRESENT_FILE);
file:mode[F]←0;file:in_bfrs[F]←0;
file:out_bfrs[F]←12; if file:ext[F]=null then file:ext[f]←"TTY";
file:chn[f]←-1;
FILE:DEVICE[F]←"DSK";
IF ¬GOT_OUTPUT(F) THEN USERERR(0,1,"Can't get output");
CHANTTYO←FILE:CHN[F];
β
ELSE CHANTTYO←-1;
β ELSE CHANTTYO←-1;
! push_source_list,pop_source_list;
RPTR(SOURCE_LIST) PROCEDURE PUSH_SOURCE_LIST(RPTR(SOURCE_LIST)S1);
α
RPTR(SOURCE_LIST) S;
S←NEW_RECORD(SOURCE_LIST);
SOURCE_LIST:NEXT[S]←S1;
SOURCE_LIST:CUR_STRING[S]←CURLINE;
SOURCE_LIST:CUR_STRINGR[S]←TOKEN_FRONT&CURLINER;
SOURCE_LIST:PN[S]←PAGENUM;
SOURCE_LIST:LN[S]←LINENUM;
SOURCE_LIST:CHAN[S]←CHANIN;
SOURCE_LIST:FILE_NAME[S]←INFILE;
SOURCE_LIST:FILE_PTR[S]←PRESENT_FILE;
SOURCE_LIST:CHANTTYO[S]←CHANTTYO;
CHANTTYO←-1;
CURLINE←CURLINER←NULL;
RETURN(S);
β;
RPTR(SOURCE_LIST) PROCEDURE POP_SOURCE_LIST(RPTR(SOURCE_LIST)S1);
α
CURLINE←SOURCE_LIST:CUR_STRING[S1];
CURLINER←SOURCE_LIST:CUR_STRINGR[S1];
PAGENUM←SOURCE_LIST:PN[S1];
LINENUM←SOURCE_LIST:LN[S1];
CHANIN←SOURCE_LIST:CHAN[S1];
PRESENT_FILE←SOURCE_LIST:FILE_PTR[S1];
INFILE←SOURCE_LIST:FILE_NAME[S1];
CHANTTYO←SOURCE_LIST:CHANTTYO[S1];
RETURN(SOURCE_LIST:NEXT[S1]);
β;
! id info processing routines;
! FLAGS
BIT 35 USE
34 DEFINE
33 AFFIX
0-9 PAGENUM
10-19 LINENUM ;
DEFINE RID1=[RPTR(ID_LIST)R1];
BOOLEAN PROCEDURE USED(RID1);
RETURN(ID_LIST:FLAGS[R1] LAND '1);
BOOLEAN PROCEDURE DEFINED(RID1);
RETURN(ID_LIST:FLAGS[R1] LAND '2);
BOOLEAN PROCEDURE AFFIXED(RID1);
RETURN(ID_LIST:FLAGS[R1] LAND '4);
PROCEDURE USE(RID1);
ID_LIST:FLAGS[R1]←ID_LIST:FLAGS[R1] LOR '1;
PROCEDURE DEFIN(RID1);
ID_LIST:FLAGS[R1]←ID_LIST:FLAGS[R1] LOR '2;
PROCEDURE AFFIX(RID1);
ID_LIST:FLAGS[R1]←ID_LIST:FLAGS[R1] LOR '4;
PROCEDURE UNFIX(RID1);
ID_LIST:FLAGS[R1]←ID_LIST:FLAGS[R1] LAND '777777777773;
PROCEDURE PUT_ID_PAGE(RID1);
ID_LIST:FLAGS[R1]←(((ID_LIST:FLAGS[R1] ROT 10)LAND '777777776000)+PAGENUM+1) ROT -10;
PROCEDURE PUT_ID_LINE(RID1);
ID_LIST:FLAGS[R1]←(((ID_LIST:FLAGS[R1] ROT 20)LAND '777777776000)+LINENUM+1) ROT -20;
INTEGER PROCEDURE ID_PAGE(RID1);
RETURN((ID_LIST:FLAGS[R1] ROT 10)LAND '1777);
INTEGER PROCEDURE ID_LINE(RID1);
RETURN((ID_LIST:FLAGS[R1] ROT 20)LAND '1777);
! read, push_macro_delimiters;
STRING PROCEDURE READ(INTEGER BTABLE);
! RIGHT NOW THIS PROCEDURE IS KIND OF DUMB. IT'S INCLUDED IN THE HOPE
OF EVENTUALLY MAKING THE READING FACILITY MORE VERSATILE;
α STRING TEXT;
text ← SCAN(CURLINER,BTABLE,BRCHAR);
WHILE BRCHAR=0 DO
α BOOLEAN REPLACED;
REPLACED←TRUE;
IF CHANIN>-1 THEN α STRING CURR;
CURLINE←CURLINER←INPUT(CHANIN,lf_ff_break);
IF CHANTTYO≥0 THEN OUT(CHANTTYO, CURLINE);
CURR←CURLINE[1 TO (LENGTH(CURLINE)-2)]&" ";
ERROR_BUFFER←ERROR_BUFFER&CURR;
BACKUP_ERROR_BUFFER←BACKUP_ERROR_BUFFER&CURR;
macro_stack_top←macro_st2; macro_st2←null_record;β;
IF CHANIN≤-1 THEN
α "pop macro"
CHANIN←SOURCE_LIST:CHAN[TOP_SOURCE];
CURLINE←SOURCE_LIST:CUR_STRING[TOP_SOURCE];
CURLINER←" "&SOURCE_LIST:CUR_STRINGR[TOP_SOURCE];
PAGENUM←SOURCE_LIST:PN[TOP_SOURCE];
LINENUM←SOURCE_LIST:LN[TOP_SOURCE];
macro_st2←SOURCE_LIST:macro_stack_TOP[TOP_SOURCE];
CURRENT_MACRO←SOURCE_LIST:CUR_MACRO[TOP_SOURCE];
TOP_SOURCE←SOURCE_LIST:NEXT[TOP_SOURCE];
β "pop macro"
ELSE IF BRCHAR=lf THEN LINENUM←LINENUM+1
ELSE IF BRCHAR=ff THEN
α
outstr(" " & cvs((PAGENUM←PAGENUM+1)+1));
typed_page_num ← true; LINENUM←0
β
ELSE IF TOP_SOURCE≠NULL THEN
α "close_source"
RELEASE(CHANIN);
IF EQU(FILE:DEVICE[PRESENT_FILE],"TTY") THEN RELEASE(CHANTTYO);
CURRENT_MACRO←NULL_RECORD;
MAC_NUM←SOURCE_LIST:NUM[TOP_SOURCE];
TOP_SOURCE←POP_SOURCE_LIST(TOP_SOURCE);
outstr(crlf); typed_page_num ← false; sourcelvl ← sourcelvl-1;
β "close_source"
ELSE IF EOF THEN ERROR(500,"end of file encountered unexpectedly.");
TEXT ← TEXT & SCAN(CURLINER,BTABLE,BRCHAR);
β;
RETURN(TEXT);
β;
procedure push_delimiters(string s);
α RPTR(delimiter_list) new_del;
DELIMITER_LIST:NEXT[NEW_DEL ← new_record(delimiter_list)] ← TOP_DELIMITERS;
DELIMITER_LIST:D1[NEW_DEL] ← lop(s); DELIMITER_LIST:D2[NEW_DEL] ← lop(s);
TOP_DELIMITERS←NEW_DEL;
β;
! macro handling routine;
BOOLEAN procedure macro_handler;
α "macro_handler"
INTEGER HASH_ENTRY; STRING MACRO_NAME;
INTEGER PARAM_COUNT;
BOOLEAN SPECIAL_DELIMS; RPTR (MACRO_LIST) MAC_POINT;
RPTR (PARAM_LIST) TOP_PARAM, NEW_PARAM, LAST_PARAM;
BOOLEAN STATUS;
LABEL FLUSH;
PROCEDURE F_STATE(VALUE INTEGER PP,IP; VALUE STRING SP);
α STRING CLOSE; INTEGER I;
FOR I←1 STEP 1 UNTIL PP DO CLOSE←CLOSE&")";
SPACING←SPACING-PP;
PRINT(CLOSE);
ERROR(IP,SP&crlf&"Continue will flush statement.");
WHILE ¬EQU(TOKEN,";") DO GET_TOKEN;
REJECT←TRUE;
STATUS←FALSE;
NUM_OF_ERRORS_FLUSHED←NUM_OF_ERRORS_FLUSHED+1;
GOTO FLUSH;
β;
procedure macro_delimiters(boolean turn_on);
α string chr1, chr2;
if turn_on
then if top_delimiters≠null_record
then
α
chr1 ← delimiter_list:d1[top_delimiters];
chr2 ← delimiter_list:d2[top_delimiters];
β
else chr1 ← chr2 ← dquote
else chr1 ← chr2 ← null;
delimiter_1 ← chr1; delimiter_2 ← chr2;
SETBREAK(macro_delimiter_break, chr1 & chr2, NULL, "ISN");
SETBREAK(word_R_break, TABLE1 & chr1, NULL, "INRK");
SETBREAK(word_S_break, TABLE1 & chr1, NULL, "INSK");
β;
STATUS←TRUE;
do α "define_macro"
INSIDE_MACRO_DEFINITION←TRUE;
SPECIAL_DELIMS←FALSE; PARAM_COUNT←0; GET_TOKEN;
INSIDE_MACRO_DEFINITION←FALSE;
IF TYPE_OF_TOKEN≠undeclared_token and SPECIAL_INFO=BLOCK_LEVEL
THEN F_STATE(0,56,"Can only define unreserved ID's.");
MACRO_NAME←TOKEN; GET_TOKEN;
IF EQU(TOKEN,"(") THEN
α "macro_parameters"
TOP_PARAM←LAST_PARAM←NEW_RECORD(PARAM_LIST);
WHILE ¬EQU(TOKEN,")") DO
α
GET_TOKEN;
IF TYPE_OF_TOKEN≠undeclared_token
THEN F_STATE(0,57,"Can only use unreserved ID's as parameter names.");
PARAM_COUNT←PARAM_COUNT+1; NEW_PARAM←NEW_RECORD(PARAM_LIST);
PARAM_LIST:NEXT[LAST_PARAM]←NEW_PARAM;
PARAM_LIST:USER_ID[NEW_PARAM]←TOKEN; LAST_PARAM←NEW_PARAM;
GET_TOKEN;
IF ¬EQU(TOKEN,")") AND ¬EQU(TOKEN,",") THEN
α
ERROR(58,"Need either comma or right paren here.");
REJECT←TRUE; TOKEN←")";
β;
β;
TOP_PARAM←PARAM_LIST:NEXT[TOP_PARAM];
GET_TOKEN;
β "macro_parameters"
ELSE TOP_PARAM←LAST_PARAM←NULL_RECORD;
IF TYPE_OF_TOKEN=string_token THEN
α "special_delimiters" RPTR (DELIMITER_LIST) NEW_DEL;
SPECIAL_DELIMS←TRUE;
IF TYPE_OF_TOKEN≠string_token THEN F_STATE(0,52,"Need string here.");
IF LENGTH(TOKEN)≠2 THEN F_STATE(0,53,"Need string of length 2.");
push_delimiters(token);
get_token;
β "special_delimiters";
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(59,"Need = here.");
macro_delimiters(true); GET_TOKEN;
IF TYPE_OF_TOKEN≠macro_body_token THEN F_STATE(0,60,"Need string here.")
ELSE
α
! bind macros;
if param_count>0 then
α "PARAMS"
string array param_id, param_arg[1:param_count];
integer i,width,digits;
string t1;
string t, processed_token;
STRING BREAK_STRING;
string t2;
RPTR(param_list) param_ptr;
param_ptr←top_param;
BREAK_STRING←NULL;
GETFORMAT(WIDTH,DIGITS);
SETFORMAT(-2,0);
if chanin>0 then t1←"00" else t1←cvs(abs(chanin));
for i ← 1 step 1 until param_count do
α
param_id[i]←param_list:user_id[param_ptr];
param_arg[i]←(param_list:id[param_ptr]← "∀∀∀∀__"& t1 & "__"&cvs(i));
param_ptr←param_list:next[param_ptr];
β;
SETFORMAT(WIDTH,DIGITS);
processed_token← NULL;
SETBREAK(word_S_break, TABLE1 & delimiter_1 & delimiter_2, NULL, "INSK");
do α
integer brchar,brchar2;
t2←scan(token,non_blank_break,brchar);
if t2≠null then processed_token←processed_token&t2;
t←scan(token,word_s_break,brchar2);
if t≠null then
α for i←1 step 1 until param_count do
if equ(t,param_id[i]) then t←param_arg[i];
processed_token←processed_token&t;
β;
if brchar2≠null then processed_token←processed_token&brchar2;
β until length(token)=0;
token←processed_token;
β "PARAMS";
! done binding macros;
β;
macro_delimiters(false);
if chanin≤-1
then mac_point←insert_entry(macro_name,macro_in_macro_type_table)
else mac_point←insert_entry(macro_name,macro_type_table);
MACRO_LIST:VALUE[MAC_POINT]←TOKEN;
MACRO_LIST:NUM[MAC_POINT]←PARAM_COUNT;
MACRO_LIST:PARAMS[MAC_POINT]←TOP_PARAM;
MACRO_LIST:BLOCK_LEVEL_OF_DEFN[MAC_POINT]←BLOCK_LEVEL;
IF top_delimiters≠null then
MACRO_LIST:DELIMITERS[MAC_POINT]←delimiter_list:d1[top_delimiters]
& delimiter_list:d2[top_delimiters];
IF SPECIAL_DELIMS THEN
α
IF NULL=TOP_DELIMITERS
THEN F_STATE(0,54,"Can't unstack special delimiters!");
TOP_DELIMITERS←DELIMITER_LIST:NEXT[TOP_DELIMITERS];
β;
get_token;
β "define_macro"
until ¬equ(token, ",");
if equ(token, ";") then reject ← true;
FLUSH: RETURN(STATUS);
β "macro_handler";
! expand_macro;
RECURSIVE PROCEDURE EXPAND_MACRO;
α RPTR(macro_list) m1;
RPTR(MACRO_CONCATENATE_LIST) C1;
STRING PROCESSED_BODY,D1,D2;
RPTR(SOURCE_LIST)NEW_SOURCE2;
PROCESSED_BODY←NULL;
NEW_SOURCE2←NEW_RECORD(SOURCE_LIST);
SOURCE_LIST:CHAN[NEW_SOURCE2]←CHANIN;
SOURCE_LIST:CUR_MACRO[NEW_SOURCE2]←CURRENT_MACRO;
CURRENT_MACRO←CUR_MACRO;
c1←MACRO_CON_HEAD;
do α "expand macro"
STRING MAC_ID; RPTR(PARAM_LIST) PARAMS;
STRING BODY;
INTEGER BRCHAR2;
M1←MACRO_CONCATENATE_LIST:MACRO_PTR[C1];
PARAMS←MACRO_LIST:PARAMS[M1];
MAC_ID←MACRO_LIST:ID[M1];
D1←MACRO_LIST:DELIMITERS[M1][1 FOR 1];
D2←MACRO_LIST:DELIMITERS[M1][2 FOR 1];
read(non_blank_break); token←read(word_R_break);
if token=null then token←read(word_s_break);
IF ¬EQU(TOKEN,"(") AND PARAMS≠NULL
THEN ERROR(59,"Parametered macro used without params.")
ELSE IF ¬EQU(TOKEN,"(")
THEN
α
IF TOKEN= NULL THEN CURLINER←BRCHAR&CURLINER ELSE
CURLINER←TOKEN&CURLINER;
BODY←MACRO_LIST:VALUE[M1];
β
ELSE
α "macro parameters"
STRING T,t2r,t3;
FOR I←1 STEP 1 UNTIL MACRO_LIST:NUM[M1] DO
α RPTR(MACRO_LIST)SUB_MACRO;
IF EQU(TOKEN,")") THEN
ERROR(60,"Number of parameters disagree with definition.");
GET_TOKEN;
! IF TYPE_OF_TOKEN≠string_token THEN
ERROR(61,"Need a string here.");
SUB_MACRO←INSERT_ENTRY(PARAM_LIST:ID[PARAMS],MACRO_IN_MACRO_TYPE_TABLE);
MACRO_LIST:VALUE[SUB_MACRO]←TOKEN;
GET_TOKEN;
IF ¬EQU(TOKEN,",") AND ¬EQU(TOKEN,")") THEN
ERROR_REJECT(62,"NEED EITHER COMMA OR RIGHT PAREN HERE.");
PARAMS←PARAM_LIST:NEXT[PARAMS];
β;
IF ¬EQU(TOKEN,")") THEN ERROR(62,"Number of parameters don't match the defn.");
body←macro_list:value[m1];
β "macro parameters";
PROCESSED_BODY←processed_body&body;
β "expand macro" until (c1←macro_concatenate_list:next[c1])=NULL_record;
SOURCE_LIST:NUM[NEW_SOURCE2]←MACRO_LIST:NUM[M1];
SOURCE_LIST:NEXT[NEW_SOURCE2]←TOP_SOURCE;
SOURCE_LIST:CUR_STRING[NEW_SOURCE2]←CURLINE;
SOURCE_LIST:CUR_STRINGR[NEW_SOURCE2]←CURLINER;
SOURCE_LIST:PN[NEW_SOURCE2]←PAGENUM;
SOURCE_LIST:LN[NEW_SOURCE2]←LINENUM;
SOURCE_LIST:MACRO_STACK_TOP[NEW_SOURCE2]←MACRO_STACK_TOP;
SOURCE_LIST:MACRO_STRING[NEW_SOURCE2]←MACRO_STRING;
SOURCE_LIST:FILE_PTR[NEW_SOURCE2]←PRESENT_FILE;
IF CHANIN≥0 THEN CHANIN←-1 ELSE CHANIN←CHANIN-1;
MACRO_STRING←processed_body;
CURLINE←CURLINER←processed_body;
TOP_SOURCE←NEW_SOURCE2;
GET_TOKEN;
WHILE EQU(TOKEN,"DEFINE") DO
α
macro_handler; get_token; GET_TOKEN;
β;
β;
! get_token;
! THIS PROCEDURE GETS THE NEXT TOKEN.
STRING TOKEN ← TOKEN FOUND
INTEGER TYPE_OF_TOKEN← SPECIAL_TOKEN, NUMERIC_TOKEN, STRING_TOKEN, ID_TOKEN,
MACRO_TOKEN, METRIC_TOKEN, UNDEFINED_TOKEN, RESERVED_TOKEN
INTEGER TYPE_OF_RES_WORD ← -VE IF NOT RESERVED WORD
INTEGER ID_TYPE ← VALID FOR TYPE_OF_TOKEN=ID_TOKEN
INTEGER SPECIAL_INFO ← PERTAINS TO INFO ABOUT RES_WORD
INTEGER BLOCK_LEVEL_OF_DEFN ← PERTAINS TO BLOCK LEVEL OF DEFN
INTEGER RESERVED_TOKEN_PTR← POINTER TO POSITION IN RESERVED,COM[0:RESERVED_HASHER]
REAL REALNUM← REAL NUMBER FOUND
RPTR TOKEN_PTR← GENERAL POINTER TO TOKEN FOUND AS ID, ETC;
RECURSIVE PROCEDURE GET_TOKEN;
α "get_token" BOOLEAN T; INTEGER POINT;
RECORD_POINTER(MACRO_LIST) PROCEDURE LOOK_FOR_MACRO;
α RECORD_POINTER (MACRO_LIST) R1;
IF MACRO_STACK_TOP≠NULL
THEN R1←CHECK_ENTRY(TOKEN,MACRO_IN_MACRO_TYPE_TABLE);
IF R1=NULL
THEN R1←CHECK_ENTRY(TOKEN,MACRO_TYPE_TABLE);
RETURN(R1);
β;
! IF REJECT THEN α REJECT←FALSE; ! ************ ; ! RETURN; ! ************; ! β;
IF REJECT THEN α CURLINER←TOKEN&CURLINER; REJECT←FALSE; β;
BLOCK_LEVEL_OF_DEFN←RESERVED_TOKEN_PTR←
ID_TYPE←TYPE_OF_RES_WORD←SPECIAL_INFO←-100;
TOKEN_PTR←NULL_RECORD;
TYPE_OF_TOKEN←special_token; T←TRUE;
WHILE T DO
α "while_T"
TOKEN_FRONT←READ(non_blank_break); TOKEN←READ(word_R_break);
IF EQU(TOKEN,NULL)
THEN
α "isolated break"
CASE BRCHAR OF
α
["."]
α REAL NUM; STRING S1; S1←CURLINER[2 FOR 1];
IF "0"≤S1≤"9"
THEN α NUM←REALSCAN(CURLINER,BRCHAR);
TYPE_OF_TOKEN←numeric_token; REALNUM←NUM; TOKEN←CVG(NUM) β
ELSE α TOKEN←"."; CURLINER←CURLINER[2 TO ∞]; β;
β;
ELSE ;
[SQUOTE]
α REAL NUM; garb←LOP(CURLINER);
IF "0"≤CURLINER[2 FOR 1]≤"7"
THEN α TYPE_OF_TOKEN←numeric_token; REALNUM←NUM;
TOKEN←CVS(NUM); REALNUM←CVO(TOKEN); β
ELSE TOKEN←squote;
β
β;
IF EQU(TOKEN,NULL) THEN α READ(word_S_break); TOKEN←BRCHAR; β;
β "isolated break";
IF EQU(TOKEN,OPEN_BRACE) THEN TOKEN←READ(close_brace_break) ELSE T←FALSE;
β "while_T";
! delimiter_1 non-zero only while defining macro;
if delimiter_1 and token=delimiter_1
then
α "found_macro_body" integer lvl;
token←read(macro_delimiter_break); type_of_token ← macro_body_token;
if delimiter_1=delimiter_2 ∨ brchar=delimiter_2 then return; ! ******** ;
lvl ← 2; if brchar≠delimiter_1 then error(200, "macro body scan lost");
do
α token ← token & brchar & read(macro_delimiter_break);
if brchar=delimiter_2
then lvl ← lvl-1
else if brchar=delimiter_1
then lvl ← lvl+1
else error(200, "macro body scan lost");
β
until lvl ≤ 0;
return; ! ************* ;
β "found_macro_body";
IF TOKEN=dquote
THEN
α "found_string"
TOKEN←READ(quote_break); TYPE_OF_TOKEN←string_token;
while curliner=dquote do token ← token & lop(curliner) & read(quote_break);
! ********* ; RETURN; ! ********** ;
β "found_string";
! look for reserved word;
IF TYPE_OF_TOKEN=special_token
THEN
α POINT←HASH(TOKEN,reserved_hasher);
WHILE ¬EQU(RESERVED[POINT],NULL) AND ¬EQU(RESERVED[POINT],TOKEN) DO
POINT←(POINT+1)MOD reserved_hasher;
IF RESERVED[POINT]=TOKEN
THEN
α "reserved word" INTEGER VAL; TYPE_OF_TOKEN←reserved_token; VAL←COM_TYPE[POINT];
RESERVED_TOKEN_PTR←POINT;
IF VAL≥reserved_hasher
THEN α SPECIAL_INFO←(VAL DIV reserved_hasher); TYPE_OF_RES_WORD←(VAL MOD reserved_hasher); β
ELSE α SPECIAL_INFO←0; TYPE_OF_RES_WORD←VAL; β;
β "reserved word";
α "not reserved"
RECORD_POINTER(ANY_CLASS)POINT,POINT2;
IF ¬("0" ≤ token ≤ "9")
THEN
α "MAC_TEST"
IF (TOKEN_PTR←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE))≠NULL_RECORD
THEN α TYPE_OF_TOKEN←ID_TOKEN; BLOCK_LEVEL_OF_DEFN←ID_LIST:BLOCK_LEVEL_OF_DEFN[TOKEN_PTR]; β;
IF (POINT2←CHECK_ENTRY(TOKEN,DIMENSION_TYPE_TABLE))≠NULL_RECORD
THEN
α IF TOKEN_PTR=NULL_RECORD
THEN α TOKEN_PTR←POINT2; TYPE_OF_TOKEN←METRIC_TOKEN;β
ELSE IF DIMENS_EXPONENT:BLOCK_LEVEL_OF_DEFN[POINT2] > BLOCK_LEVEL_OF_DEFN
THEN α TYPE_OF_TOKEN←METRIC_TOKEN; TOKEN_PTR←POINT2;
BLOCK_LEVEL_OF_DEFN←DIMENS_EXPONENT:BLOCK_LEVEL_OF_DEFN[TOKEN_PTR]; β;
β;
IF (CUR_MACRO←LOOK_FOR_MACRO)≠NULL_RECORD
THEN IF TOKEN_PTR=NULL_RECORD OR MACRO_LIST:BLOCK_LEVEL_OF_DEFN[CUR_MACRO]>
BLOCK_LEVEL_OF_DEFN
THEN
α "MACRO"
string ttoken; record_pointer (macro_concatenate_list) ptr;
record_pointer(macro_list)r1;
BLOCK_LEVEL_OF_DEFN←MACRO_LIST:BLOCK_LEVEL_OF_DEFN[CUR_MACRO];
PTR←(MACRO_CON_HEAD←NEW_RECORD(MACRO_CONCATENATE_LIST));
macro_concatenate_list:macro_ptr[ptr]←cur_macro;
read(non_blank_break); ttoken←read(word_R_break);
while ttoken= null and brchar="&"
do α
curliner←curliner[2 to ∞]; read(non_blank_break);
token←read(word_S_break);
if (r1←look_for_macro) = null
then
α error(1111, "Need macro name here.");
curliner←token&brchar&curliner;
β
else
α ptr←(macro_concatenate_list:next[ptr]←new_record(macro_concatenate_list));
macro_concatenate_list:macro_ptr[ptr]←r1;
read(non_blank_break);ttoken←read(word_r_break);
β;
β;
curliner←ttoken&curliner;
EXPAND_MACRO;
β "MACRO";
β "MAC_TEST"
ELSE
α "numeric" REAL NUM1,NUM2; INTEGER NUMGARB;
TYPE_OF_TOKEN←numeric_token; NUM1←INTSCAN(TOKEN,NUMGARB);
IF ¬EQU(TOKEN,NULL) THEN ERROR(0,"Illegal token." & crlf & "Garbage after digits will be ignored.");
IF BRCHAR="."
THEN
α CURLINER←"0"&CURLINER; NUM2←REALSCAN(CURLINER,BRCHAR);
TOKEN←CVG(NUM1+NUM2);
REALNUM←NUM1+NUM2;
β
ELSE IF BRCHAR="@"
THEN
α CURLINER←"1"&CURLINER; NUM2←REALSCAN(CURLINER,BRCHAR);
TOKEN←CVG(NUM1*NUM2);
REALNUM←NUM1*NUM2;
β
ELSE α TOKEN←CVG(NUM1); REALNUM←NUM1; β;
β "numeric";
β "not reserved";
β;
if type_of_token=id_token
then α if ¬inside_declare_p then use(token_ptr);
if id_list:type[token_ptr]=string_value
then if inside_string_declaration
then id_type←string_value
else α type_of_token←string_token; token←id_list:body[token_ptr]; token_ptr←null_record; β
else id_type←id_list:type[token_ptr];
β
else if type_of_token=special_token then type_of_token←undeclared_token;
β "get_token";
! check_token,check_token_type;
boolean procedure check_next_token(integer err_code; string err_mess,
s1,s2(null),s3(null),s4(null),s5(null),s6(null),
s7(null),s8(null),s9(null),s10(null));
α string array s[1:10]; integer i1,j1;label l1,l2; string st;
s[1]←s1;s[2]←s2;s[3]←s3;s[4]←s4;s[5]←s5;s[6]←s6;s[7]←s7;s[8]←s8;s[9]←s9;s[10]←s10;
i1←0;st←null;
while s[i1+1]≠null do α i1←i1+1;st←st & s[i1] & ","; β;
if i1 > 1 then
α
l1: get_token;
for j1←1 step 1 until i1
do if equ(token , s[j1]) then return(true);
patch_code←true;
error(err_code,err_mess&crlf&"Need one of "&st& " here, patchable error ");
if patch_code=true
then α patch_code←false; return(false); β
else goto l1;
β else
α
l2: get_token;
if equ(token,s1) then return(true);
patch_code←true;
error(err_code,err_mess&crlf&"Need "&s1&" here, continue will insert it.");
if patch_code = true
then α patch_code←false; return(false); β
else goto l2;
β;
β;
boolean procedure check_token(integer err_code; string err_mess,
s1,s2(null),s3(null),s4(null),s5(null),s6(null),
s7(null),s8(null),s9(null),s10(null));
α
reject←true;
return(check_next_token(err_code,err_mess,s1,s2,s3,s4,s5,s6,s7,s8,s9,s10));
β;
boolean procedure check_next_token_type(integer err_code; string err_mess;
integer ttype);
α Label l1;
get_token;
l1: if type_of_token=ttype then return(true);
patch_code←true;
error(err_code,err_mess);
if patch_code=true then α patch_code←false; return(false); β
else goto l1;
β;
boolean procedure check_token_type(integer err_code; string err_mess;
integer ttype);
α
reject←true;
return(check_next_token_type(err_code,err_mess,ttype));
β;
boolean procedure token_equ(string s1,s2(null),s3(null),s4(null),s5(null),
s6(null),s7(null),s8(null),s9(null),s10(null));
α string s;
for s←s1,s2,s3,s4,s5,s6,s7,s8,s9,s10
do if equ(null,s) then return(false)
else if equ(token,s) then return(true);
return(false);
β;
! check, inverse, multiply and divide dimensions; ! CHECK_EXP_TYPE_DIMENS;
RPTR(DIMENS_EXPONENT)
PROCEDURE CHECK_DIMENSIONS(STRING S; RPTR(DIMENS_EXPONENT) D1,D2);
α RPTR(DIMENS_EXPONENT)II1,II2,II3;STRING SS;BOOLEAN SAME;
SS←NULL;
SAME←TRUE;
II1←D1; II2←D2;
IF II1≠II2 THEN
α IF II1=NULL_RECORD THEN II1←NIL_DIMENS;
IF II2=NULL_RECORD THEN II2←NIL_DIMENS;
redefine xx(temp)= [ IF DIMENS_EXPONENT:temp[II1]≠DIMENS_EXPONENT:temp
[II2] THEN α IF LENGTH(SS)≠0 THEN SS←SS&", temp " ELSE SS←" temp ";
SAME←FALSE;β;];
IF ¬STRICT_DIMEN_CHECK OR ((II2≠NIL_DIMENS) AND (II1≠NIL_DIMENS))
THEN α BASIC_DIMENSIONS;
IF SAME THEN II3←II1
ELSE ERROR(122, SS & "Dimensions don't match on "&S&".");
β
ELSE IF II1≠NIL_DIMENS THEN II3←II1 ELSE II3←II2;
β
ELSE IF II1=NULL_RECORD THEN II3←NIL_DIMENS ELSE II3←II1;
IF SAME THEN RETURN(II3);
β;
RPTR(DIMENS_EXPONENT)
PROCEDURE INVERSE_DIMENSIONS(RPTR(DIMENS_EXPONENT)D2);
α
RPTR(DIMENS_EXPONENT) D1;
IF D2≠NULL_RECORD THEN
α
RPTR(DIMENS_EXPONENT) II2;
D1←NEW_RECORD(DIMENS_EXPONENT);
II2←D2;
redefine xx(temp)=[DIMENS_EXPONENT:temp[D1]←-DIMENS_EXPONENT:temp[II2];];
BASIC_DIMENSIONS;
β
ELSE D1←NULL_RECORD;
RETURN(D1);
β;
RPTR(DIMENS_EXPONENT)
PROCEDURE MULTIPLY_DIMENSIONS(RPTR(DIMENS_EXPONENT)D2,D3);
α
RPTR(DIMENS_EXPONENT) D1;
IF D2=NULL_RECORD OR D3=NULL_RECORD THEN
α
IF D2≠NULL_RECORD THEN D1←D2
ELSE IF D3≠NULL_RECORD THEN D1←D3;
β
ELSE
α
RPTR(DIMENS_EXPONENT) II2,II3;
D1←NEW_RECORD(DIMENS_EXPONENT);
II2←D2;II3←D3;
redefine xx(temp)=[DIMENS_EXPONENT:temp[D1]←DIMENS_EXPONENT:temp[II2]+
DIMENS_EXPONENT:temp[II3];];
BASIC_DIMENSIONS;
β;
RETURN(D1);
β;
RPTR(DIMENS_EXPONENT)
PROCEDURE DIVIDE_DIMENSIONS(RPTR(DIMENS_EXPONENT)D2,D3);
α
RPTR(DIMENS_EXPONENT) D1;
IF D2=NULL_RECORD OR D3=NULL_RECORD THEN
α
IF D2≠NULL_RECORD THEN D1←D2
ELSE IF D3≠NULL_RECORD THEN D1←INVERSE_DIMENSIONS(D3);
β
ELSE
α
RPTR(DIMENS_EXPONENT)II2,II3;
D1←NEW_RECORD(DIMENS_EXPONENT);
II2←D2;II3←D3;
redefine xx(temp)=[DIMENS_EXPONENT:temp[D1]←DIMENS_EXPONENT:temp[II2]-
DIMENS_EXPONENT:temp[II3];];
BASIC_DIMENSIONS;
β;
RETURN(D1);
β;
BOOLEAN PROCEDURE CHECK_EXP_TYPE_DIMENS(INTEGER DESIRED_EXP_TYPE;
RPTR(DIMENS_EXPONENT) PTR;
STRING ERROR_MESS);
α
CHECK_DIMENSIONS(ERROR_MESS,PTR,EXP_DIMENS);
IF EXP_TYPE=DESIRED_EXP_TYPE THEN RETURN (TRUE) ELSE RETURN (FALSE);
β;
! check_entry,insert_entry into tables;
RPTR (ANY_CLASS) PROCEDURE CHECK_ENTRY (STRING S; INTEGER TABLE_TYPE);
α
RPTR(ANY_CLASS)R1;
CASE TABLE_TYPE OF
α
[ID_TYPE_TABLE] α R1←SYMBOL_TABLE[HASH(S,ID_HASHER)];
WHILE R1≠NULL AND ¬EQU(S,ID_LIST:NAME[R1]) DO R1←ID_LIST:NEXT[R1];
β;
[MACRO_TYPE_TABLE] α R1←MACRO_TABLE[HASH(S,MACRO_HASHER)];
WHILE R1≠NULL AND ¬EQU(S,MACRO_LIST:ID[R1]) DO R1←MACRO_LIST:NEXT[R1];
β;
[MACRO_IN_MACRO_TYPE_TABLE]
α R1←MACRO_STACK_TOP;
WHILE R1≠NULL AND ¬EQU(S,MACRO_LIST:ID[MACRO_STACK:LIST_PTR[R1]])
DO R1←MACRO_STACK:STACK_LINK[R1];
IF R1≠NULL_RECORD THEN R1←MACRO_STACK:LIST_PTR[R1];
β;
[DIMENSION_TYPE_TABLE]
α R1←DIMENS_TABLE[HASH(S,METRIC_HASHER)];
WHILE R1≠NULL AND ¬ EQU(S,DIMENS_EXPONENT:NAME[R1]) DO R1←DIMENS_EXPONENT:NEXT[R1];
β
β;
RETURN(R1);
β;
RPTR (ANY_CLASS) PROCEDURE INSERT_ENTRY (STRING S; INTEGER TABLE_TYPE;
RPTR(ANY_CLASS) RR1(NULL_RECORD));
α
RPTR(ANY_CLASS) R1; INTEGER INDEX;
CASE TABLE_TYPE OF
α
[ID_TYPE_TABLE] α
IF RR1=NULL_RECORD THEN R1←NEW_RECORD(ID_LIST) ELSE R1←RR1;
ID_LIST:NEXT[R1]←SYMBOL_TABLE[INDEX←HASH(S,ID_HASHER)];
ID_LIST:NAME[R1]←S;
SYMBOL_TABLE[INDEX]←R1;
IF ¬INITIALIZE THEN
α ID_LIST:LAST[R1]←TOP_ID;
ID_LIST:BLOCK_LEVEL_OF_DEFN[R1]←BLOCK_LEVEL;
PUT_ID_PAGE(R1); PUT_ID_LINE(R1);
TOP_ID←R1;DEC_NUM←DEC_NUM+1; β;
β;
[MACRO_TYPE_TABLE] α
IF RR1=NULL_RECORD THEN R1←NEW_RECORD(MACRO_LIST) ELSE R1←RR1;
MACRO_LIST:NEXT[R1]←MACRO_TABLE[INDEX←HASH(S,MACRO_HASHER)];
MACRO_LIST:ID[R1]←S;
MACRO_TABLE[INDEX]←R1;
IF ¬INITIALIZE THEN α MACRO_LIST:LAST[R1]←TOP_MACRO;
TOP_MACRO←R1; MACRO_DEC_NUM←MACRO_DEC_NUM+1; β;
β;
[MACRO_IN_MACRO_TYPE_TABLE]
α
RPTR (macro_list)r2;
IF RR1=NULL_RECORD THEN R2←NEW_RECORD(MACRO_list) ELSE R2←RR1;
r1←new_record(macro_stack);
MACRO_STACK:STACK_LINK[R1]←macro_stack_top;
macro_stack:list_ptr[r1]←r2;
MACRO_STACK_TOP←R1;
macro_list:id[r2]←s;
R1←R2;
β;
[DIMENSION_TYPE_TABLE]
α
IF RR1=NULL_RECORD THEN R1←NEW_RECORD(DIMENS_EXPONENT) ELSE R1←RR1;
DIMENS_EXPONENT:NAME[R1]←S;
DIMENS_EXPONENT:NEXT[R1]←DIMENS_TABLE[INDEX←HASH(S,METRIC_HASHER)];
DIMENS_TABLE[INDEX]←R1;
IF ¬INITIALIZE THEN α DIMENS_EXPONENT:LAST[R1]←TOP_DIMENS;
TOP_DIMENS←R1; DIMEN_DEC_NUM←DIMEN_DEC_NUM+1; β;
β
β;
RETURN(R1);
β;
! reduce, fail_up,vmake_R,vv_trans_R;
PROCEDURE REDUCE;
α INTEGER CUR_OP_NUM; LABEL RAISE;
PROCEDURE FAIL_UP(INTEGER I; STRING S);
α RPTR(EXPR)E;RPTR(EXPR_LIST)EL;
ERROR(I,S&crlf&"I will reduce it to GARB_ID as default.");
E←NEW_RECORD(EXPR);
EL←NEW_RECORD(EXPR_LIST);
EXPR:TYPE[E]←scalar_VALUE;
EXPR:OP[E]←null;
EXPR:ID[E]←"GARB_ID";
EXPR_LIST:NEXT[EL]←EXPRS;
EXPR_LIST:EXP[EL]←E;
EXPRS←EL;
GO TO RAISE;
β;
procedure vmake_vvtrans_R(BOOLEAN vm_vv);
α RPTR (EXPR_LIST) CUR_PARTS,TEMP;
RPTR (EXPR) CUR_EXPR,TEMP2;
RPTR (DIMENS_EXPONENT) D_PTR;
STRING E_OP;INTEGER E_TYPE; INTEGER TYPE_VALUE;
INTEGER I;
IF VM_VV THEN α E_OP←"VMAKE";E_TYPE←vector_VALUE; TYPE_VALUE← scalar_VALUE; β
ELSE α E_OP←"VVVTRANS"; E_TYPE←rot_VALUE; TYPE_VALUE←vector_VALUE; β;
D_PTR←NULL_RECORD;
FOR I←1 STEP 1 UNTIL 3 DO
α
IF EXPRS=NULL_RECORD THEN FAIL_UP(107,"Can't reduce expression.");
TEMP←EXPRS;
EXPRS←EXPR_LIST:NEXT[EXPRS];
EXPR_LIST:NEXT[TEMP]←CUR_PARTS;
CUR_PARTS←TEMP;
IF TYPE_VALUE≠EXPR:TYPE[TEMP2←EXPR_LIST:EXP[CUR_PARTS]]
THEN ERROR(108,"Type mismatch");
IF D_PTR=NULL_RECORD THEN D_PTR←EXPR:DIMEN[TEMP2]
ELSE D_PTR←CHECK_DIMENSIONS("VECTOR",D_PTR,EXPR:DIMEN[TEMP2]);
β;
CUR_EXPR←NEW_RECORD(EXPR);
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
EXPR:OP[CUR_EXPR]←E_OP;
EXPR:TYPE[CUR_EXPR]←E_TYPE;
EXPR:DIMEN[CUR_EXPR]←D_PTR;
TEMP←NEW_RECORD(EXPR_LIST);
EXPR_LIST:EXP[TEMP]←CUR_EXPR;
EXPR_LIST:NEXT[TEMP]←EXPRS;
EXPRS←TEMP;
β;
procedure vmake_R;
vmake_vvtrans_R(TRUE); ! VMAKE found;
procedure vvtrans_R;
vmake_vvtrans_R(FALSE); ! VVTRANS FOUND;
! tmake_r, fmake_r;
procedure ft_make(Boolean tr);
α RPTR (EXPR_LIST) CUR_PARTS,TEMP;
RPTR (EXPR) E1,E2,E3;
STRING MAKE, FT;
IF TR THEN α MAKE←"TMAKE"; FT←" trans"; β
ELSE α MAKE←"FMAKE"; FT←" frame"; β;
IF EXPRS=NULL_RECORD OR EXPR_LIST:NEXT[EXPRS]=NULL_RECORD THEN
FAIL_UP(108,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
EXPRS←EXPR_LIST:NEXT[EXPRS];
E2←EXPR_LIST:EXP[EXPRS];
IF EXPR:TYPE[E1]≠vector_VALUE THEN
α E3←E1; E1←E2; E2←E3; β;
IF EXPR:TYPE[E1]≠vector_VALUE OR EXPR:TYPE[E2]≠rot_VALUE
THEN ERROR(109,"Type mismatch.");
CHECK_DIMENSIONS("vector part of"&FT,EXPR:DIMEN[E1],DISTANCE_DIMENS);
CHECK_DIMENSIONS("rot part of"&FT,EXPR:DIMEN[E2],ANGLE_DIMENS);
TEMP←NEW_RECORD(EXPR_LIST);
EXPR_LIST:EXP[TEMP]←E1;
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[CUR_PARTS]←TEMP;
EXPR_LIST:EXP[CUR_PARTS]←E2;
E3←NEW_RECORD(EXPR);
EXPR:PARTS[E3]←CUR_PARTS;
EXPR:OP[E3]←MAKE;
EXPR:TYPE[E3]←trans_VALUE;
IF ¬TR THEN EXPR:DIMEN[E3]←distance_dimens; ! TO ENSURE THAT TRANS*TRANS WILL
NOT GIVE DIMENSIONS OF DISTANCE*DISTANCE;
EXPR_LIST:EXP[EXPRS]←E3;
β;
procedure tmake_R;
ft_make(TRUE); ! TMAKE FOUND;
procedure fmake_R;
ft_make(FALSE); ! FMAKE FOUND;
! sneg_R,rinv_R, sabs_R;
procedure sneg_R;
α RPTR (EXPR_LIST) CUR_PARTS,TEMP; ! "SNEG" FOUND;
RPTR (EXPR) CUR_EXPR,E1,E2,E3;
IF EXPRS=NULL_RECORD THEN FAIL_UP(109,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
IF EXPR:TYPE[E1]≠scalar_VALUE THEN ERROR(112,"You can only take the opposite of scalars."
&crlf&"Continue will pass the bug through.");
CUR_EXPR←NEW_RECORD(EXPR);
EXPR:OP[CUR_EXPR]←"SNEG";
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:EXP[CUR_PARTS]←E1;
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
EXPR:TYPE[CUR_EXPR]←scalar_VALUE;
EXPR:DIMEN[CUR_EXPR]←EXPR:DIMEN[E1];
EXPR_LIST:EXP[EXPRS]←CUR_EXPR;
β;
procedure rinv_R;
α RPTR (EXPR_LIST) CUR_PARTS,TEMP; ! "RINV" FOUND;
RPTR (EXPR) CUR_EXPR,E1;
IF EXPRS=NULL_RECORD THEN FAIL_UP(109,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
CUR_EXPR←NEW_RECORD(EXPR);
IF EXPR:TYPE[E1]=rot_VALUE THEN
α
EXPR:OP[CUR_EXPR]←"RINV";
EXPR:TYPE[CUR_EXPR]←rot_VALUE;
β
ELSE IF EXPR:TYPE[E1]=trans_VALUE THEN
α
EXPR:OP[CUR_EXPR]←"TINVRT";
EXPR:TYPE[CUR_EXPR]←trans_VALUE;
β
ELSE ERROR(112,"You can only take the inverse of rotations and transforms."
&crlf&"Continue will pass bug through.");
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:EXP[CUR_PARTS]←E1;
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
EXPR:DIMEN[CUR_EXPR]←INVERSE_DIMENSIONS(EXPR:DIMEN[E1]);
EXPR_LIST:EXP[EXPRS]←CUR_EXPR;
β;
procedure sabs_R;
α ! "SABS" SHOULD BE HANDLED IN P_EXP; ERROR(-1,"PARSER ERROR"); β;
! plus_R,minus_R;
procedure plus_minus_R(boolean plus);
α
STRING S,V,TV, COMMM;
RPTR (EXPR_LIST) CUR_PARTS,TEMP;
RPTR (EXPR) CUR_EXPR,E1,E2,E3;
IF PLUS THEN α S←"SADD"; V←"VADD"; TV←"TVADD"; COMMM←"addition "; β
ELSE α S←"SSUB"; V←"VSUB"; TV←"TVSUB"; COMMM←"subtraction "; β;
IF EXPRS=NULL_RECORD THEN FAIL_UP(109,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
EXPRS←EXPR_LIST:NEXT[EXPRS];
IF EXPRS=NULL_RECORD THEN FAIL_UP(110,"Can't reduce expression.");
E2←EXPR_LIST:EXP[EXPRS];
IF EXPR:TYPE[E1]≥EXPR:TYPE[E2] THEN α E3←E1; E1←E2; E2←E3; β;
TEMP←NEW_RECORD(EXPR_LIST);
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[CUR_PARTS]←TEMP;
EXPR_LIST:EXP[TEMP]←E1;
EXPR_LIST:EXP[CUR_PARTS]←E2;
CUR_EXPR←NEW_RECORD(EXPR);
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
EXPR:DIMEN[CUR_EXPR]←CHECK_DIMENSIONS(COMMM&"expression",EXPR:DIMEN[E1],EXPR:DIMEN[E2]);
IF EXPR:TYPE[E1]=scalar_VALUE THEN
α
IF EXPR:TYPE[E2]≠scalar_VALUE THEN ERROR(109,"Type mismatch.");
EXPR:OP[CUR_EXPR]←S;
EXPR:TYPE[CUR_EXPR]←scalar_VALUE;
β
ELSE IF EXPR:TYPE[E1]=vector_VALUE THEN
α
IF EXPR:TYPE[E2]=vector_VALUE THEN
α
EXPR:OP[CUR_EXPR]←V;
EXPR:TYPE[CUR_EXPR]←vector_VALUE;
β
ELSE IF EXPR:TYPE[E2]=trans_VALUE THEN
α
EXPR:OP[CUR_EXPR]←TV;
EXPR:TYPE[CUR_EXPR]←trans_VALUE;
β
β
ELSE ERROR(109,"Type mismatch");
EXPR_LIST:EXP[EXPRS]←CUR_EXPR;
β;
procedure plus_R;
plus_minus_R(TRUE); ! "+" FOUND;
procedure minus_R;
plus_minus_R(FALSE); ! "-" FOUND;
! times_R;
procedure times_R;
α RPTR (EXPR_LIST) CUR_PARTS,TEMP; ! "*" FOUND;
RPTR (EXPR) CUR_EXPR,E1,E2,E3;
IF EXPRS=NULL_RECORD THEN FAIL_UP(109,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
EXPRS←EXPR_LIST:NEXT[EXPRS];
IF EXPRS=NULL_RECORD THEN FAIL_UP(110,"Can't reduce expression.");
E2←EXPR_LIST:EXP[EXPRS];
IF EXPR:TYPE[E2]=vector_VALUE THEN α E3←E1; E1←E2; E2←E3; β;
TEMP←NEW_RECORD(EXPR_LIST);
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[CUR_PARTS]←TEMP;
EXPR_LIST:EXP[TEMP]←E1;
EXPR_LIST:EXP[CUR_PARTS]←E2;
CUR_EXPR←NEW_RECORD(EXPR);
EXPR:DIMEN[CUR_EXPR]←
MULTIPLY_DIMENSIONS(EXPR:DIMEN[E1],EXPR:DIMEN[E2]);
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
IF EXPR:TYPE[E1]≤trans_VALUE
THEN CASE EXPR:TYPE[E1] OF
α "E1"
[scalar_VALUE] α
IF EXPR:TYPE[E2]≠scalar_VALUE THEN ERROR(109,"Type mismatch.");
EXPR:OP[CUR_EXPR]←"SMUL";
EXPR:TYPE[CUR_EXPR]←scalar_VALUE;
β;
[vector_VALUE] IF EXPR:TYPE[E2]≤trans_VALUE
THEN CASE EXPR:TYPE[E2] OF
α "E2"
[scalar_VALUE] α
EXPR:OP[CUR_EXPR]←"SVMUL";
EXPR:TYPE[CUR_EXPR]←vector_VALUE;
β;
[vector_VALUE] ERROR(109,"Type mismatch.");
[rot_VALUE] α
EXPR:OP[CUR_EXPR]←"RVMUL";
EXPR:TYPE[CUR_EXPR]←vector_VALUE;
EXPR:DIMEN[CUR_EXPR]←EXPR:DIMEN[E1];
β;
[frame_VALUE] ERROR(109,"Type mismatch.");
[plane_VALUE] ERROR(109,"Type mismatch.");
[trans_VALUE] α
EXPR:OP[CUR_EXPR]←"TVMUL";
EXPR:TYPE[CUR_EXPR]←vector_VALUE;
β
β "E2"
ELSE ERROR(109,"Type mismatch.");
[rot_VALUE] α
IF EXPR:TYPE[E2]≠rot_VALUE THEN ERROR(109,"Type mismatch.");
EXPR:OP[CUR_EXPR]←"RRMUL";
EXPR:TYPE[CUR_EXPR]←rot_VALUE;
EXPR:DIMEN[CUR_EXPR]←ANGLE_DIMENS;
β;
[frame_VALUE] ERROR(120,"Type mismatch.");
[plane_VALUE] ERROR(120,"Type mismatch.");
[trans_VALUE] α
IF EXPR:TYPE[E2]≠trans_VALUE THEN ERROR(109,"Type mismatch.");
EXPR:OP[CUR_EXPR]←"TTMUL";
EXPR:TYPE[CUR_EXPR]←trans_VALUE;
β
β "E1"
ELSE ERROR(109,"Type mismatch");
EXPR_LIST:EXP[EXPRS]←CUR_EXPR;
β;
! rot_R, wrt_R;
procedure rot_R;
α RPTR (EXPR_LIST) CUR_PARTS,TEMP; ! "ROT" FOUND;
RPTR (EXPR) CUR_EXPR,E1,E2,E3;
IF EXPRS=NULL_RECORD THEN FAIL_UP(109,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
! CHECK_DIMENSIONS("angle part of ROT", EXPR:DIMEN[E1],ANGLE_DIMENS);
IF EXPR:TYPE[E1]≠scalar_VALUE THEN ERROR(109,"Type mismatch.");
EXPRS←EXPR_LIST:NEXT[EXPRS];
IF EXPRS=NULL_RECORD THEN FAIL_UP(110,"Can't reduce expression.");
E2←EXPR_LIST:EXP[EXPRS];
IF EXPR:TYPE[E2]≠vector_VALUE THEN ERROR(109,"Type mismatch.");
TEMP←NEW_RECORD(EXPR_LIST);
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[CUR_PARTS]←TEMP;
EXPR_LIST:EXP[TEMP]←E1;
EXPR_LIST:EXP[CUR_PARTS]←E2;
CUR_EXPR←NEW_RECORD(EXPR);
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
EXPR:OP[CUR_EXPR]←"AXW_ROTN";
EXPR:TYPE[CUR_EXPR]←rot_VALUE;
EXPR:DIMEN[CUR_EXPR]←ANGLE_DIMENS;
EXPR_LIST:EXP[EXPRS]←CUR_EXPR;
β;
procedure wrt_R;
α RPTR (OP_LIST) OP_SAVE;
COMMENT
vector WRT frame
GETS TRANSLATED TO
(TVMUL (ORIENT frame) vector)
SO THIS PROCEDURE MERELY CHAANGES THE TOP OF THE OP_LIST
DOING NO REAL REDUCTION. THE REDUCTION IS THEN DONE ON THE
FOLLOWING TWO PASSES. (NOTE: THIS MEANS THAT THE PRECEDENCE
OF WRT IS DIFFERENT DEPENDING ON WHICH SIDE YOU SEE IT FROM.
NOTE THAT ABOVE IS NOT CORRECT, BUT HERE IS WHAT'S DONE.
[vector WRT frame] gets translated
into (RVMUL (ORIENT frame) vector) instead of (TVMUL (ORIENT frame) vector).
That's because (ORIENT frame) returns a rotation, not a translation.
;
OP_LIST:OP[OPS]←times_X;
OPSAVE←OPS;
OPS←NEW_RECORD(OP_LIST);
OP_LIST:NEXT[OPS]←OPSAVE;
OP_LIST:PRIORITY[OPS]← SPECIAL_INFO;
OP_LIST:NUM_OF_ARGS[OPS]←OP_NUM[orient_X];
OP_LIST:FUNC[OPS]←FALSE;
OP_LIST:ARG_DEP[OPS]←OP_BOOL[orient_X];
OP_LIST:OP[OPS]←orient_X;
COMMENT NOTE THAT THE END OF REDUCE (where the execution goes next)
WILL THROW AWAY THE TOP OP ON OP_LIST, SO WE'RE GOING TO
PUT ON A DUMMY OPERATOR;
OPSAVE←OPS;
OPS←NEW_RECORD(OP_LIST);
OP_LIST:NEXT[OPS]←OPSAVE;
β;
! →_R;
procedure →_R;
α RPTR (EXPR_LIST) CUR_PARTS,TEMP; ! "→" FOUND;
RPTR (EXPR) CUR_EXPR,E1,E2,E3;
IF EXPRS=NULL_RECORD THEN FAIL_UP(109,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
EXPRS←EXPR_LIST:NEXT[EXPRS];
IF EXPRS=NULL_RECORD THEN FAIL_UP(110,"Can't reduce expression.");
E2←EXPR_LIST:EXP[EXPRS];
IF EXPR:TYPE[E1]≠EXPR:TYPE[E2] THEN ERROR(111,"Type mismatch.");
TEMP←NEW_RECORD(EXPR_LIST);
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[CUR_PARTS]←TEMP;
EXPR_LIST:EXP[TEMP]←E1;
EXPR_LIST:EXP[CUR_PARTS]←E2;
CUR_EXPR←NEW_RECORD(EXPR);
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
EXPR:DIMEN[CUR_EXPR]←
MULTIPLY_DIMENSIONS(EXPR:DIMEN[E1],EXPR:DIMEN[E2]);
IF EXPR:TYPE[E1]=vector_VALUE THEN
α
EXPR:OP[CUR_EXPR]←"VTOV";
EXPR:TYPE[CUR_EXPR]←rot_VALUE;
β
ELSE IF EXPR:TYPE[E1]=trans_VALUE THEN
α
EXPR:OP[CUR_EXPR]←"FTOF";
EXPR:TYPE[CUR_EXPR]←trans_VALUE;
β
ELSE ERROR(109,"Type mismatch");
EXPR_LIST:EXP[EXPRS]←CUR_EXPR;
β;
! reduce execution starts here;
CUR_OP_NUM←OP_LIST:OP[OPS];
IF ¬(1 ≤ CUR_OP_NUM ≤ op_count)
THEN FAIL_UP(1030,"Trying to parse expression and found garbage.");
IF OP_BOOL[CUR_OP_NUM] THEN
CASE CUR_OP_NUM - first_true_op OF
α
redefine xx(str1, i1, boole, i2, i3, i4, str2)=[
ifc boole
thenc
redefine xx_temp=ifc "str2"=null thenc [str1] elsec [str2] endc & "_R";
xx_temp;
endc ];
operator_definitions;
β
ELSE α RPTR(EXPR_LIST) CUR_PARTS,TEMP;
RPTR (EXPR) CUR_EXPR;
INTEGER I;
FOR I←1 STEP 1 UNTIL OP_NUM[CUR_OP_NUM] DO
α
IF EXPRS=NULL_RECORD THEN FAIL_UP(107,"Can't reduce expression.");
TEMP←EXPRS;
EXPRS←EXPR_LIST:NEXT[EXPRS];
EXPR_LIST:NEXT[TEMP]←CUR_PARTS;
CUR_PARTS←TEMP;
IF TYPE_OF_ARGS[CUR_OP_NUM]≠EXPR:TYPE[EXPR_LIST:EXP[CUR_PARTS]]
AND TYPE_OF_ARGS[CUR_OP_NUM]≥0
THEN ERROR(108,"Type mismatch");
β;
CUR_EXPR←NEW_RECORD(EXPR);
CASE DIMEN_CHANGES[CUR_OP_NUM] OF
α
[ignore_dimen] ;
[same_dimen] α
EXPR:DIMEN[CUR_EXPR]←EXPR:DIMEN[EXPR_LIST:EXP[CUR_PARTS]];
β;
[inverse_dimen] α
EXPR:DIMEN[CUR_EXPR]←
INVERSE_DIMENSIONS(EXPR:DIMEN[EXPR_LIST:EXP[CUR_PARTS]]);
β;
[check_dimen] α RPTR(EXPR) E1,E2;
E1←EXPR_LIST:EXP[CUR_PARTS];
E2←EXPR_LIST:EXP[EXPR_LIST:NEXT[CUR_PARTS]];
EXPR:DIMEN[CUR_EXPR]←CHECK_DIMENSIONS("expression",EXPR:DIMEN[E1],EXPR:DIMEN[E2]);
β;
[multiply_dimen] EXPR:DIMEN[CUR_EXPR]←
MULTIPLY_DIMENSIONS(
EXPR:DIMEN[EXPR_LIST:EXP[CUR_PARTS]],
EXPR:DIMEN[EXPR_LIST:EXP[EXPR_LIST:NEXT[CUR_PARTS]]]);
[divide_dimen] EXPR:DIMEN[CUR_EXPR]←
DIVIDE_DIMENSIONS(
EXPR:DIMEN[EXPR_LIST:EXP[CUR_PARTS]],
EXPR:DIMEN[EXPR_LIST:EXP[EXPR_LIST:NEXT[CUR_PARTS]]])
β;
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
EXPR:OP[CUR_EXPR]←OP_ARRAY[CUR_OP_NUM];
IF RESULT_TYPE[CUR_OP_NUM]≥0 THEN
EXPR:TYPE[CUR_EXPR]←RESULT_TYPE[CUR_OP_NUM] ELSE
EXPR:TYPE[CUR_EXPR]←EXPR:TYPE[EXPR_LIST:EXP[CUR_PARTS]];
TEMP←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[TEMP]←EXPRS;
EXPR_LIST:EXP[TEMP]←CUR_EXPR;
EXPRS←TEMP;
β;
RAISE: OPS←OP_LIST:NEXT[OPS];
β;
! printexpr;
RECURSIVE PROCEDURE PRINTEXPR(RPTR (EXPR) E);
IF EQU(EXPR:OP[E],null) THEN OUTEXPR←OUTEXPR&EXPR:ID[E]
ELSE α RPTR (EXPR_LIST) SUBS;
OUTEXPR←OUTEXPR&"("&EXPR:OP[E];
SUBS←EXPR:PARTS[E];
WHILE SUBS≠NULL DO
α
OUTEXPR←OUTEXPR&" ";
PRINTEXPR(EXPR_LIST:EXP[SUBS]);
SUBS←EXPR_LIST:NEXT[SUBS];
β;
OUTEXPR←OUTEXPR&")";
β;
! string_expr;
STRING PROCEDURE STRING_EXPR;
α
STRING BODY,NEXT_STRING; BOOLEAN TO_FOR; INTEGER K1,K2;
GET_TOKEN; BODY←NULL;
IF TYPE_OF_TOKEN=STRING_TOKEN
THEN NEXT_STRING←TOKEN
else if type_of_token=numeric_token
then next_string←NULL&realnum
ELSE ERROR(37, "Need string token here");
GET_TOKEN;
WHILE TOKEN="&" OR TOKEN="[" DO
α
IF TOKEN="&"
THEN
α GET_TOKEN; IF BODY≠NULL THEN BODY←BODY&NEXT_STRING ELSE BODY←NEXT_STRING;
IF TYPE_OF_TOKEN=STRING_TOKEN
THEN NEXT_STRING←TOKEN
else if type_of_token=numeric_token
then next_string←NULL& realnum
ELSE ERROR(37, "Need string token here");
GET_TOKEN;
β
ELSE
α BOOLEAN TOFOR; GET_TOKEN;IF TYPE_OF_TOKEN≠NUMERIC_TOKEN THEN ERROR(38,"Need numeric token here") else k1←realnum;
get_token;
IF EQU(TOKEN,"TO") OR EQU(TOKEN,"FOR")
THEN
α IF TOKEN="TO" THEN TOFOR←TRUE ELSE TOFOR←FALSE; GET_TOKEN; K2←REALNUM;
GET_TOKEN; IF TOKEN≠"]" THEN ERROR_REJECT(39, "Need ""]"" here, continue will insert.");
β
ELSE ERROR(37, "Need TO or FOR here");
IF TOFOR THEN NEXT_STRING←NEXT_STRING[K1 TO K2] ELSE NEXT_STRING←NEXT_STRING[K1 FOR K2];
GET_TOKEN;
β;
β;
REJECT←TRUE;
RETURN(BODY&NEXT_STRING);
β;
! p_exp2;
! PARSE EXPRESSIONS AND SAVE PARSED STRUCTURE INTERNALLY FOR LATER PRINTING;
PROCEDURE P_EXP2;
α RPTR (ID_LIST) POINT; LABEL FLUSH;
PROCEDURE F_EXP(INTEGER IP; STRING SP);
α RPTR(EXPR)E;
ERROR(IP,SP&crlf&"Continue will attempt to flush expression.");
WHILE ( TYPE_OF_TOKEN=id_token
OR (EQU(TOKEN,"(") AND ¬OP_EXPECTED)
OR TYPE_OF_TOKEN=numeric_token
OR (operator_beg ≤ TYPE_OF_RES_WORD ≤ operator_end)
OR TYPE_OF_RES_WORD=declare_RES)
DO GET_TOKEN;
OPS←NULL_RECORD;
if exprs≠null_record then
α
E←NEW_RECORD(EXPR);
EXPR:TYPE[E]←scalar_VALUE;
EXPR:ID[E]←"GARB_ID";
EXPR_LIST:NEXT[EXPRS]←NULL_RECORD;
EXPR_LIST:EXP[EXPRS]←E;
β;
GO TO FLUSH;
β;
BOOLEAN PROCEDURE MODIFY_CONTINUE(INTEGER ERR_NO; STRING MESS);
α CAN_MODIFY←TRUE; ERROR(ERR_NO,"Modifiable error, continue will try to recover"&crlf&MESS);
IF MODIFIED
THEN α CURLINE←CURLINER←ERROR_BUFFER; REJECT←FALSE; GET_TOKEN; MODIFIED←FALSE; RETURN(TRUE); β
ELSE α CAN_MODIFY←FALSE; RETURN(MODIFIED) β;
β;
! parse_special;
procedure parse_special;
α "parse_special" integer j;
define expected_ops=[
xx([(], -1, -1, false, false)
xx([|], sabs_X, -1, true, false)
! xx([-], sneg_X, vector_RES, false, false) ;
xx([/], rinv_X, vector_RES, false, false)
xx(NOT, not_X, not_RES, false, false)
xx([¬], not_X, not_RES, false, false)
xx(VVTRANS, vvtrans_X, vector_RES, false, true)
xx(ROT, rot_X, vector_RES, true, true)
xx(VVROT, vvrot_X, vector_RES, false, true)
xx(VDOT, vdot_X, vector_RES, false, true)
xx(ANGLE, angle_X, vector_RES, false, true)
xx(INV, rinv_X, vector_RES, false, true)
];
define
op_case=0;
redefine xx(token, op_num, prior, arg_dep, func)=[
redefine op_case=op_case+1;];
expected_ops;
redefine xx(token, op_num, prior, arg_dep, func)=["token",];
preload_array(
expected_name, expected_ops, [own string], 0, op_case);
redefine xx(token, op_num, prior, arg_dep, func)=[op_num,];
preload_array(
expected_X, expected_ops, [own integer], 0, op_case);
redefine xx(token, op_num, prior, arg_dep, func)=[prior,];
preload_array(
expected_prior, expected_ops, [own integer], 0, op_case);
redefine xx(token, op_num, prior, arg_dep, func)=[arg_dep,];
preload_array(
expected_arg, expected_ops, [own boolean], 0, op_case);
redefine xx(token, op_num, prior, arg_dep, func)=[func,];
preload_array(
expected_func, expected_ops, [own boolean], 0, op_case);
OPSAVE←OPS; OPS←NEW_RECORD(OP_LIST);
OP_LIST:NEXT[OPS]←OPSAVE;
IF TOKEN="+" OR TOKEN = "-" THEN SPECIAL_INFO←TIMES_X;
OP_LIST:PRIORITY[OPS] ← SPECIAL_INFO;
for j←0 step 1 until op_case-1 do if equ(token,expected_name[j]) then done;
if j ≤ op_case-1
then
α integer k;
OP_LIST:PRIORITY[OPS] ← expected_prior[j];
OP_LIST:OP[OPS] ← k ← expected_X[j];
OP_LIST:NUM_OF_ARGS[OPS] ← if k<0 then 1 else op_num[k];
op_list:count[ops] ← 0;
OP_LIST:ARG_DEP[OPS] ← expected_arg[j];
op_list:func[ops] ← expected_func[j];
if token="(" then no_op_so_far←true;
β
ELSE IF EQU(TOKEN,"⊗")
THEN
α
EXP1←NEW_RECORD(EXPR);
EXPR:TYPE[EXP1]←trans_VALUE;
EXPR:OP[EXP1]←null;
IF EQU(CURRENT_FRAME,null) THEN
ERROR(1111,"⊗ used outside of MOVE, AFFIX, or UNAFFIX statement is illegal.");
EXPR:ID[EXP1]←CURRENT_FRAME;
EXPR:DIMEN[EXP1]←distance_dimens;
EXPRSAVE←EXPRS;
EXPRS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[EXPRS]←EXPRSAVE;
EXPR_LIST:EXP[EXPRS]←EXP1;
OPS←OP_LIST:NEXT[OPS];
OP_EXPECTED←TRUE;
β
ELSE IF TYPE_OF_RES_WORD=declare_RES
THEN
α "declare_RES"
case special_info of
α "special_info"
[vector_VALUE] α ! VMAKE FOUND;
OP_LIST:OP[OPS] ← vmake_X;
OP_LIST:NUM_OF_ARGS[OPS] ← op_num[vmake_X];
β;
[frame_VALUE] α ! FMAKE FOUND;
OP_LIST:OP[OPS] ← fmake_X;
OP_LIST:NUM_OF_ARGS[OPS] ← op_num[fmake_X];
β;
[trans_VALUE] α ! TMAKE FOUND;
OP_LIST:OP[OPS] ← tmake_X;
OP_LIST:NUM_OF_ARGS[OPS] ← op_num[tmake_X];
β;
[0]
[scalar_VALUE]
[rot_VALUE]
[plane_VALUE] F_EXP(103,"Illegal operator.")
β "special_info";
OP_LIST:COUNT[OPS]←0;
OP_LIST:ARG_DEP[OPS]←FALSE;
OP_LIST:FUNC[OPS]←TRUE;
β "declare_RES"
ELSE if special_info
then
α
IF TOKEN="+" OR TOKEN="-"
then
IF NO_OP_SO_FAR THEN
α
EXP1←NEW_RECORD(EXPR);
EXPR:TYPE[EXP1]←scalar_VALUE;
EXPR:OP[EXP1]←null;
EXPR:ID[EXP1]←token&"1.000000";
EXPRSAVE←EXPRS;
EXPRS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[EXPRS]←EXPRSAVE;
EXPR_LIST:EXP[EXPRS]←EXP1;
β
ELSE ERROR(25,"Cannot have two + or - together");
OP_LIST:OP[OPS]←SPECIAL_INFO;
OP_LIST:ARG_DEP[OPS]←OP_BOOL[SPECIAL_INFO];
OP_LIST:NUM_OF_ARGS[OPS]←OP_NUM[SPECIAL_INFO];
β
else f_exp(200, "Doesn't make sense.");
if equ(token,"(") then no_op_so_far←true else no_op_so_far←false;
β "parse_special";
! p_exp2 execution begins here, p_exp;
label re_try;
error_buffer←curliner;
GET_TOKEN;
re_try:
no_op_so_far←true;
OP_EXPECTED←FALSE; EXPRS←NULL_RECORD; ops←NULL_RECORD; EXP1←EXP2←EXP3←NULL_RECORD; OUTEXPR←null;
WHILE ( (TYPE_OF_TOKEN=id_token AND ID_TYPE<CM_LABEL_VALUE)
OR (EQU(TOKEN,"(") AND ¬OP_EXPECTED)
OR TYPE_OF_TOKEN=numeric_token
OR (operator_beg ≤ TYPE_OF_RES_WORD ≤ operator_end)
OR TYPE_OF_RES_WORD=declare_RES)
DO
α "while"
IF OP_EXPECTED THEN
α "op_expected"
IF EQU(TOKEN,"ROT") THEN
α
TYPE_OF_TOKEN←reserved_token;
TYPE_OF_RES_WORD←trans_RES;
no_op_so_far←true;
SPECIAL_INFO←rot_X;
β;
IF TYPE_OF_TOKEN≠reserved_token OR EQU(TOKEN,"(")
THEN F_EXP(101,"Operation needed here.");
α "termin_check" integer match, j; string str;
match ← -1; j←0;
for str ← ")", ",", "|" do
if equ(str, token)
then α match ← j; done β
else j ← j+1;
if match ≥ 0
then case match of
α "match"
! ")"; α
WHILE OPS≠NULL_RECORD AND OP_LIST:OP[OPS]≠-1 DO REDUCE;
IF OPS=NULL_RECORD THEN done "while";
OPS←OP_LIST:NEXT[OPS];
IF OPS≠NULL_RECORD AND OP_LIST:FUNC[OPS]=TRUE THEN REDUCE;
β;
! ","; α
WHILE OPS≠NULL_RECORD AND OP_LIST:OP[OPS]≠-1 DO REDUCE;
NO_OP_SO_FAR←TRUE;
IF OPS=NULL THEN done "while";
OP_EXPECTED←FALSE;
β;
! "|"; α
WHILE OPS≠NULL_RECORD AND OP_LIST:OP[OPS]≠17 DO REDUCE;
IF OPS=NULL_RECORD
THEN F_EXP(105,"Mismatched vertical paren.");
OPS←OP_LIST:NEXT[OPS];
EXP1←NEW_RECORD(EXPR);
EXPR:PARTS[EXP1]←NEW_RECORD(EXPR_LIST);
EXPR_LIST:EXP[EXPR:PARTS[EXP1]]←EXPR_LIST:EXP[EXPRS];
EXPR:DIMEN[EXP1]
← EXPR:DIMEN[EXPR_LIST:EXP[EXPRS]];
EXPR:TYPE[EXP1]←scalar_VALUE;
CASE (EXPR:TYPE[EXPR_LIST:EXP[EXPRS]]) OF
α
[scalar_VALUE] EXPR:OP[EXP1]←"SABS";
[vector_VALUE] EXPR:OP[EXP1]←"VMAGN";
[rot_VALUE] EXPR:OP[EXP1]←"RMAGN";
ELSE ERROR(106,"Type mismatch for |.|.")
β;
EXPR_LIST:EXP[EXPRS]←EXP1;
β
β "match"
ELSE
α
IF TYPE_OF_RES_WORD=0
THEN F_EXP(1000,"Sorry, OP not implemented yet.");
WHILE OPS≠NULL_RECORD AND OP_LIST:PRIORITY[OPS]≥TYPE_OF_RES_WORD
DO REDUCE;
OPSAVE←OPS;
OPS←NEW_RECORD(OP_LIST);
OP_LIST:NEXT[OPS]←OPSAVE;
OP_LIST:PRIORITY[OPS]←TYPE_OF_RES_WORD;
OP_LIST:NUM_OF_ARGS[OPS]←OP_NUM[SPECIAL_INFO];
OP_LIST:FUNC[OPS]←FALSE;
OP_LIST:ARG_DEP[OPS]←OP_BOOL[SPECIAL_INFO];
OP_LIST:OP[OPS]←SPECIAL_INFO;
OP_EXPECTED←FALSE;
β
β "termin_check"
β "op_expected"
ELSE case TYPE_OF_TOKEN of
α "type_of_token"
[id_token] α
EXP1←NEW_RECORD(EXPR);
EXPR:TYPE[EXP1]←ID_LIST:TYPE[TOKEN_PTR];
EXPR:DIMEN[EXP1]←ID_LIST:DIMEN[TOKEN_PTR];
EXPR:OP[EXP1]←null;
EXPR:ID[EXP1]←TOKEN;
EXPRSAVE←EXPRS;
EXPRS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[EXPRS]←EXPRSAVE;
EXPR_LIST:EXP[EXPRS]←EXP1;
no_op_so_far←false;
OP_EXPECTED←TRUE;
β;
[numeric_token] α
EXP1←NEW_RECORD(EXPR);
EXPR:TYPE[EXP1]←scalar_VALUE;
EXPR:OP[EXP1]←null;
EXPR:ID[EXP1]←TOKEN;
EXPRSAVE←EXPRS;
EXPRS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[EXPRS]←EXPRSAVE;
EXPR_LIST:EXP[EXPRS]←EXP1;
no_op_so_far←false;
OP_EXPECTED←TRUE;
β;
[undeclared_token] if modify_continue(17, "Undeclared token ⊂"&token&"⊃") then goto re_try;
[reserved_token] parse_special;
[string_token] F_EXP(100,"Illegal expression.")
β "type_of_token";
GET_TOKEN;
β "while";
FLUSH:
REJECT←TRUE;
WHILE OPS≠NULL_RECORD DO REDUCE;
IF EXPRS=NULL
THEN
α
if modify_continue(107,"Empty expression, continue will insert GARBID") then goto re_try;
EXPRS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:EXP[EXPRS]←NEW_RECORD(EXPR);
EXPR:ID[EXPR_LIST:EXP[EXPRS]]←"GARB_ID";
β
ELSE IF EXPR_LIST:NEXT[EXPRS]≠NULL THEN ERROR(107,"Can't reduce expression.");
EXP_DIMENS←EXPR:DIMEN[EXPR_LIST:EXP[EXPRS]];
PRINTEXPR(EXPR_LIST:EXP[EXPRS]);
EXP_TYPE←EXPR:TYPE[EXPR_LIST:EXP[EXPRS]];
β;
! PARSE EXPRESSIONS AND IMMEDIATELY PRINT EXPRESSION IN ALCODE FORM;
PROCEDURE P_EXP;
α
P_EXP2;
PRINT(OUTEXPR);
β;
! P_condition;
! CONDITION FINDER - NOT YET INCLUDED;
BOOLEAN PROCEDURE P_CONDITION(INTEGER PP;STRING PRELUDE);
α STRING COND,OP; LABEL FLUSH; RPTR(DIMENS_EXPONENT)PTR;
PROCEDURE F_STATE(VALUE INTEGER IP; VALUE STRING SP);
α STRING CLOSE; INTEGER I;
ERROR(IP,SP&crlf&"Continue will flush statement.");
WHILE ¬EQU(TOKEN,";") DO GET_TOKEN;
REJECT←TRUE;
NUM_OF_ERRORS_FLUSHED←NUM_OF_ERRORS_FLUSHED+1;
GO TO FLUSH;
β;
GET_TOKEN;
IF ID_TYPE=event_Value THEN
α PRINT(PRELUDE& " " & TOKEN);
RETURN(FALSE);
β;
IF TYPE_OF_RES_WORD=cm_RES or equ(token,"FORCE") OR EQU(TOKEN,"TORQUE") THEN
α "CM_RES"
INTEGER FORCE_TYPE;
IF SPECIAL_INFO=nil_CM
THEN COND←TOKEN
ELSE
α ! YOU MIGHT WANT TO INCORPORATE ALL OF THIS INTO P_EXP2;
FORCE_TYPE←SPECIAL_INFO;
if force_type=torque_CM or force_type=force_cm
then
α COND←" FORCE "; GET_TOKEN;
IF FORCE_TYPE=TORQUE_CM THEN PTR←TORQUE_DIMENS ELSE PTR←FORCE_DIMENS;
IF EQU(TOKEN,"(")
THEN
α "("
P_EXP2;
IF EXP_TYPE≠vector_VALUE THEN F_STATE(1202,"Need vector here.");
COND←COND&" "&OUTEXPR; GET_TOKEN;
IF ¬EQU(TOKEN,")")
THEN ERROR(1201,"Need right paren here. Continue will insert it.");
GET_TOKEN;
IF ¬TOKEN_EQU("=","<","≤",">","≥")
THEN ERROR(1202,"Need relational operator here");
if TOKEN_EQU("≤")
THEN TOKEN←"<"
ELSE IF TOKEN_EQU(">") THEN TOKEN←"≥";
PRINT(PRELUDE&" ("&COND& " "&token); SPACING←SPACING+1; P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,PTR,"Force or Torque condition monitor")
THEN ERROR(49,"Need scalar quantity here.");
if force_type=force_cm
then PRINT(" + )")
else if force_type=torque_cm then print(" - )") ELSE PRINT (" )");
SPACING←SPACING-1; RETURN(FALSE);
β "("
ELSE
IF TOKEN_EQU("=","<","≤","≥",">")
THEN
α "="
STRING REL_OP, SCAL_EXP,VECT_EXP,FFFF,PLUS_MIN;
REL_OP←TOKEN;
IF TOKEN_EQU("≤")
THEN REL_OP←"<"
ELSE IF TOKEN_EQU(">") THEN REL_OP←"≥";
IF FORCE_TYPE=FORCE_CM THEN PLUS_MIN ← " + " ELSE PLUS_MIN←" - ";
P_EXP2; FFFF←null;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,PTR,"Force or Torque condition monitor")
THEN ERROR(49,"Need scalar quantity here.");
SCAL_EXP←OUTEXPR; GET_TOKEN;
IF ¬TOKEN_EQU("ALONG","ABOUT")
THEN
α if ¬token_equ("WITH","ON",";")
THEN ERROR(1205,"Need ALONG or ABOUT here, continue will insert it.");
REJECT←TRUE;
β
ELSE
α P_EXP2;
IF ¬CHECK_EXP_TYPE_DIMENS(Vector_value, Nil_dimens,"direction vector")
then error(48, "Need vector expression here");
vect_exp←outexpr; GET_TOKEN;
IF ¬TOKEN_EQU("OF") THEN REJECT←TRUE
ELSE
α P_EXP2;
IF EXP_TYPE≠TRANS_VALUE AND EXP_TYPE≠ROT_VALUE
THEN ERROR(1206, "Need frame or rot value here");
FFFF←"( FORCE_FRAME "&outexpr; GET_TOKEN;
IF ¬TOKEN_EQU("IN")
THEN α REJECT←TRUE; FFFF←FFFF& " # )"; β
ELSE
α GET_TOKEN;
IF TOKEN_EQU("WORLD","STATION","FIXED")
THEN FFFF←FFFF & " # )"
ELSE
IF TOKEN_EQU("HAND","BHAND","YHAND","MOVING")
THEN FFFF←FFFF& " ⊗ )"
ELSE
α ERROR(1209, "Need FIXED or MOVING here, Continue will treat as station");
FFFF←FFFF&" # )";
β;
GET_TOKEN;
if ¬token_equ("COORD","COORDS","COORDINATES")
THEN REJECT←TRUE;
β;
β;
β;
print(PRELUDE);
PRINT("("&COND& " "&VECT_EXP&" "
& REL_OP & " " & SCAL_EXP& " "&
PLUS_MIN & FFFF& " )");
β "="
ELSE ERROR(1204, "Need relational operator here");
β
ELSE
IF FORCE_TYPE=duration_CM
THEN
α PTR←TIME_DIMENS; cond← " DURATION "; GET_TOKEN;
PRINT(PRELUDE&" ("&COND& " "&token);
SPACING←SPACING+1; P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,PTR,"Duration condition monitor")
THEN ERROR(49,"Need scalar quantity here.");
PRINT (" )"); SPACING←SPACING-1; RETURN(FALSE);
β
ELSE
α ERROR(1203, "Only force or torque condition monitor allowed");
print(" )");
β;
β;
β "CM_RES"
ELSE
α P_EXP2;
IF EXP_TYPE≠boole_Value and EXP_TYPE≠scalar_VALUE
THEN F_STATE(44, "Need boolean expression or force_type predicate in condition monitor");
PRINT(PRELUDE); print(outexpr); return(false);
β;
FLUSH: RETURN(TRUE);
β;
! P_clauses, T_gen;
PROCEDURE P_CLAUSES;
α "P_CLAUSES"
BOOLEAN T; LABEL FLUSH; BOOLEAN ICMT;STRING LABL; INTEGER LAB_TYPE;
PROCEDURE F_STATE(VALUE INTEGER IP; VALUE STRING SP);
α STRING CLOSE; INTEGER I;
ERROR(IP,SP&crlf&"Continue will flush statement.");
WHILE ¬EQU(TOKEN,";") DO GET_TOKEN;
REJECT←TRUE;
NUM_OF_ERRORS_FLUSHED←NUM_OF_ERRORS_FLUSHED +1;
GO TO FLUSH;
β;
ICMT←INSIDE_CONDITION_MONITOR;
T←TRUE; GET_TOKEN;
WHILE T DO
α
LABL←NULL;
IF (LAB_TYPE←ID_TYPE)=CM_LABEL_VALUE
THEN IF DEFINED(TOKEN_PTR)
THEN ERROR(123,TOKEN& " already used.")
ELSE
α DEFIN(TOKEN_PTR); LABL←TOKEN;
INSIDE_CONDITION_MONITOR←TRUE;
GET_TOKEN;
IF ¬EQU(TOKEN,":") THEN ERROR(23,"Need colon after label " & LABL & " .") ELSE GET_TOKEN;
β;
IF (TYPE_OF_RES_WORD=on_RES) AND ( (LABL=NULL) OR (LAB_TYPE=CM_LABEL_VALUE) )
THEN
α
INSIDE_CONDITION_MONITOR←TRUE;
IF EQU(TOKEN,"ON") THEN P_CONDITION(2,"( "&LABL& "ON +")
ELSE α CHECK_NEXT_TOKEN(37, NULL,"ON"); P_CONDITION(2,"( " & LABL& "ON -"); β;
SPACING←SPACING+1;GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN ERROR_REJECT(45,"Need DO here. Continue will insert it.");
P_STATEMENT;SPACING←SPACING-1; PRINT(")"); GET_TOKEN;
β
ELSE IF EQU(TOKEN,"(") THEN
α INTEGER C; STRING TEMP;
! LEFT PAREN FOUND - STAIGHT TRANSFER;
C←1; TEMP←"(";
WHILE C>0 DO
α
TEMP←TEMP&READ(paren_cr_break);
IF BRCHAR="("
THEN C←C+1
ELSE IF BRCHAR=")"
THEN C←C-1
ELSE α PRINT(TEMP); TEMP←NULL; β;
β;
PRINT(TEMP); GET_TOKEN;
β
ELSE IF ¬(move_beg ≤ TYPE_OF_RES_WORD ≤ move_end) THEN
α
! END OF MOVE STATEMENT FOUND;
REJECT←TRUE; T←FALSE;
β
ELSE CASE TYPE_OF_RES_WORD - move_beg OF
α
[via_X] α ! VIA CLAUSE FOUND;
PRINT("(VIA "); SPACING←SPACING+1; P_EXP;
IF EXP_TYPE≠frame_exp_VALUE THEN ERROR(1202, "Need trans value expression here");
GET_TOKEN;
IF EQU(TOKEN,",") THEN
α SPACING←SPACING-1; PRINT(")");
WHILE EQU(TOKEN,",") DO
α
PRINT("(VIA "); SPACING←SPACING+1; P_EXP;
IF EXP_TYPE≠frame_exp_VALUE THEN ERROR(1202, "Need trans value expression here");
SPACING←SPACING-1; PRINT(")"); GET_TOKEN;
β;
β
ELSE α BOOLEAN V_FOUND,D_FOUND,CONTIN; CONTIN←TRUE;
IF EQU(TOKEN,"WHERE") THEN
WHILE ¬(V_FOUND ∧ D_FOUND) ∧ CONTIN DO
α
GET_TOKEN;
IF V_FOUND ∧ EQU(TOKEN,"VELOCITY") THEN
F_STATE(3011,"Multiple VELOCITY specification found in WITH clause.")
ELSE IF EQU(TOKEN,"VELOCITY") THEN
α PRINT("(VELOCITY "); GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(3014,"Need = here.");
SPACING←SPACING+1; P_EXP;
SPACING←SPACING-1; PRINT(")");
IF ¬CHECK_EXP_TYPE_DIMENS(vector_VALUE,VELOCITY_DIMENS,
"Velocity expression") THEN
α
SPACING←SPACING-1; PRINT(")");
F_STATE(3012,"Need a vector expression here.");
β;
V_FOUND←TRUE; GET_TOKEN;
IF ¬EQU(TOKEN,",") THEN CONTIN←FALSE;
β
ELSE IF D_FOUND ∧ EQU(TOKEN,"DURATION") THEN
F_STATE(3013,"Multiple DURATION specification found in WITH clause.")
ELSE IF EQU(TOKEN,"DURATION") THEN
α
GET_TOKEN;
IF ¬(EQU(TOKEN,"=") ∨ EQU(TOKEN,"<") ∨ EQU(TOKEN,">")) THEN
ERROR_REJECT(3014,"Need =,<, or > here.");
PRINT("(DURATION " & TOKEN & " ");
SPACING←SPACING+1;P_EXP;SPACING←SPACING-1;
PRINT(")");
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE, TIME_DIMENS,
"DUARATION clause")THEN
α SPACING←SPACING-1; PRINT(")");
F_STATE(3012,"Need a scalar expression here.");
β;
D_FOUND←TRUE; GET_TOKEN;
IF ¬EQU(TOKEN,",") THEN CONTIN←FALSE;
β
ELSE CONTIN←FALSE;
β;
IF EQU(TOKEN,"THEN") THEN
α PRINT("(THEN"); SPACING←SPACING+1; P_STATEMENT; SPACING←SPACING-1;
PRINT(")");GET_TOKEN;
β;
SPACING←SPACING-1; PRINT(")");
β;
β;
[directly_X] α
PRINT ("(ARRIVAL NILDEPROACH)");
PRINT ("(DEPARTURE NILDEPROACH)");get_token;
β;
[with_X] α;
GET_TOKEN;
IF TYPE_OF_RES_WORD=approach_RES THEN
α "APPROACH_RES"
if equ(token,"ARRIVAL")
then ERROR(-1,"Use APPROACH instead of ARRIVAL")
else if equ(token,"APPROACH") then token←"ARRIVAL";
PRINT("(" & TOKEN); SPACING←SPACING+1; GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(3022,"Need = here.");
GET_TOKEN;
IF EQU(TOKEN,"NILDEPROACH") THEN PRINT("NILDEPROACH")
ELSE IF EQU(TOKEN,"DEPROACH") THEN
α
PRINT("(DEPR"); SPACING←SPACING+1; GET_TOKEN;
IF ¬EQU(TOKEN,"(") THEN ERROR_REJECT(3019,"Need left paren here.");
P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(frame_exp_VALUE,DISTANCE_DIMENS,
"FRAME expression")
THEN F_STATE(3020,"Need frame exp here.");
GET_TOKEN;
IF ¬EQU(TOKEN,")") THEN ERROR_REJECT(3021,"Need right paren here.");
SPACING←SPACING-1; PRINT(")");
β
ELSE α
REJECT←TRUE;P_EXP;
IF EXP_TYPE≠scalar_VALUE ∧ EXP_TYPE≠vector_VALUE ∧ EXP_TYPE≠trans_VALUE THEN
ERROR(3018,"Type mismatch for DEPROACH.");
β;
SPACING←SPACING-1; PRINT(")");
β "APPROACH_RES"
ELSE IF EQU(TOKEN,"WOBBLE") THEN
α "WOBBLE"
GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(3022, "Need = here.");
PRINT("(WOBBLE "); SPACING←SPACING+1; P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE, ANGLE_DIMENS,
"WOBBLE Clause")
THEN F_STATE(3012,"Need a scalar expression here.");
SPACING←SPACING - 1;PRINT(")");
β "WOBBLE"
ELSE IF EQU(TOKEN,"FORCE") OR EQU(TOKEN, "TORQUE")
THEN α REJECT←TRUE; P_CONDITION(2,NULL); β
ELSE IF EQU(TOKEN,"DURATION") THEN
α;
GET_TOKEN;
IF ¬(EQU(TOKEN,"=") ∨ EQU(TOKEN,"<") ∨ EQU(TOKEN,">")) THEN
ERROR_REJECT(3014,"Need =,<, or > here.");
PRINT("(DURATION " & TOKEN & " ");
SPACING←SPACING+1; P_EXP; SPACING←SPACING-1; PRINT(")");
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,TIME_DIMENS,
"DURATION clause")
THEN F_STATE(3012,"Need a scalar expression here.");
β
ELSE IF EQU(TOKEN,"SPEED_FACTOR") THEN
α
GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN
ERROR_REJECT(3014,"Need = here.");
P_EXP2;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,NIL_DIMENS,
"DURATION clause")
THEN F_STATE(3012,"Need a scalar expression here.");
PRINT("(SPEED_FACTOR "& OUTEXPR & " )");
β
ELSE IF EQU(TOKEN,"FORCE_FRAME") THEN
α
STRING FFFF;
GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN
ERROR_REJECT(3014,"Need = here.");
P_EXP2;
IF EXP_TYPE≠trans_VALUE and EXP_TYPE≠rot_VALUE THEN
ERROR(3012,"Need a trans or rot expression here.");
GET_TOKEN;
IF ¬EQU(TOKEN,"IN") THEN error_REJECT(46,"Need IN here, will insert it");
GET_TOKEN;
IF TOKEN_EQU("STATION","TABLE","WORLD","FIXED") THEN
FFFF←" #"
ELSE IF TOKEN_EQU("HAND","BHAND","YHAND","MOVING")
THEN FFFF←" ⊗" ELSE FFFF←NULL;
PRINT("(FORCE_FRAME " & OUTEXPR & FFFF & " )");
get_token;
IF ¬TOKEN_EQU("COORD","COORDS","COORDINATED") THEN REJECT←TRUE;
β
ELSE F_STATE(3016,"Illegal WITH clause.");
GET_TOKEN;
β
β;
β;
FLUSH: INSIDE_CONDITION_MONITOR←ICMT;
β "P_CLAUSES";
STRING PROCEDURE T_GEN;
α
T_COUNT←T_COUNT+1;
RETURN("_T"&CVS(T_COUNT));
β;
! P_statement, F_state, modify_continue, modify_flush;
RECURSIVE PROCEDURE P_STATEMENT;
α "P_STATEMENT"
LABEL GLOBAL_RE_TRY;
LABEL FLUSH,TRY_AGAIN; STRING LABL; INTEGER LABEL_TYPE;
RPTR(DIMENS_EXPONENT) DIM_PTR;
PROCEDURE F_STATE(VALUE INTEGER PP,IP(-10000); VALUE STRING SP(NULL));
α STRING CLOSE; INTEGER I;
FOR I←1 STEP 1 UNTIL PP DO CLOSE←CLOSE&")";
SPACING←SPACING-PP;
PRINT(CLOSE);
IF SP≠NULL THEN ERROR(IP,SP&crlf&"Continue will flush statement.");
WHILE ¬EQU(TOKEN,";") DO GET_TOKEN;
REJECT←TRUE;
NUM_OF_ERRORS_FLUSHED←NUM_OF_ERRORS_FLUSHED +1;
GO TO FLUSH;
β;
BOOLEAN PROCEDURE MODIFY_CONTINUE(INTEGER ERR_NO; STRING MESS);
α CAN_MODIFY←TRUE; ERROR(ERR_NO,"Modifiable error, continue will try to recover"&crlf&MESS);
IF MODIFIED
THEN α CURLINE←CURLINER←ERROR_BUFFER; GET_TOKEN; MODIFIED←FALSE; RETURN(TRUE); β
ELSE α CAN_MODIFY←FALSE; RETURN(MODIFIED) β;
β;
BOOLEAN PROCEDURE MODIFY_FLUSH(INTEGER PP,ERR_NO; STRING MESS);
α CAN_MODIFY←TRUE; ERROR(ERR_NO,"Modifiable error, continue will flush statement"&crlf&MESS);
IF MODIFIED
THEN α CURLINE←CURLINER←ERROR_BUFFER; GET_TOKEN; MODIFIED←FALSE;RETURN(TRUE); β
ELSE α CAN_MODIFY←FALSE; F_STATE(PP); β;
β;
BOOLEAN PROCEDURE MODIFY_BACKUP_FLUSH(INTEGER PP,ERR_NO; STRING MESS);
α BACKUP_MODIFY←TRUE; CAN_MODIFY←TRUE;
ERROR(ERR_NO,"Modifiable error - type M to modify G to backup - continue will flush statement");
IF MODIFIED
THEN α CURLINE←CURLINER←ERROR_BUFFER; GET_TOKEN;BACKUP_MODIFY←MODIFIED←FALSE;RETURN(TRUE);β
ELSE IF BACKUP_MODIFIED
THEN α CURLINE←CURLINER←ERROR_BUFFER←BACKUP_ERROR_BUFFER; GET_TOKEN;
BACKUP_MODIFIED←FALSE; GOTO GLOBAL_RE_TRY; β
ELSE α CAN_MODIFY←BACKUP_MODIFY←FALSE; F_STATE(PP); β;
β;
BOOLEAN PROCEDURE MODIFY_BACKUP_CONTINUE(INTEGER ERR_NO;STRING MESS);
α BACKUP_MODIFY←TRUE;
IF MODIFY_CONTINUE(ERR_NO, "Type M to modify, G to backup"&crlf&MESS)
THEN α BACKUP_MODIFY←FALSE; RETURN(TRUE); β
ELSE IF BACKUP_MODIFIED
THEN α BACKUP_MODIFIED←FALSE; CURLINE←CURLINER←ERROR_BUFFER←BACKUP_ERROR_BUFFER;
GET_TOKEN; GOTO GLOBAL_RE_TRY; β
ELSE RETURN(FALSE);
β;
DEFINE MODIFY_FLUSH_MACRO(str)=[ IF MODIFY_FLUSH(str) THEN GOTO RE_TRY ];
DEFINE MODIFY_CONTINUE_MACRO(str) = [ IF MODIFY_CONTINUE(str) THEN GOTO RE_TRY ];
DEFINE MODIFY_BACKUP_FLUSH_MACRO(str)= [IF MODIFY_BACKUP_FLUSH(str) THEN GOTO RE_TRY ];
DEFINE MODIFY_BACKUP_CONTINUE_MACRO(str)= [IF MODIFY_BACKUP_CONTINUE(str) THEN GOTO RE_TRY ];
! begin_P,end_P, open_paren_P;
recursive procedure begin_P;
α INTEGER SAVE_DEC_NUM,SAVE_MACRO_DEC_NUM,SAVE_DIMEN_DEC_NUM;
EXTERNAL RECORD!POINTER(ANY!CLASS) PROCEDURE $REC$(INTEGER OP;
RECORD!POINTER(ANY!CLASS) R);
record_pointer(any_class) rr;
STRING B1,B2,E1,E2,TT; STRING S, BLK_NAME, BLK_NAME_END;
STRING UNUSED_S;
IFC DEFIN_PRINT_SWITCH THENC STRING UNDEFINED_S;ENDC
TT←"("&LABL;
B1←B2←"BEGIN";
E1←E2←"END";
BLOCK_LEVEL←BLOCK_LEVEL+1;
SAVE_DEC_NUM←DEC_NUM; DEC_NUM←0;
SAVE_MACRO_DEC_NUM←MACRO_DEC_NUM; MACRO_DEC_NUM←0;
SAVE_DIMEN_DEC_NUM←DIMEN_DEC_NUM; DIMEN_DEC_NUM←0;
IF EQU(TOKEN,"BEGIN") THEN
α B2←"CO"&B2;E2←"CO"&E2;TT←TT&"BL";β
ELSE α B1←"CO"&B1;E1←"CO"&E1;TT←TT&"CO";β;
GET_TOKEN;
IF TYPE_OF_TOKEN=STRING_TOKEN AND TOKEN_PTR=NULL_RECORD
THEN BLK_NAME←TOKEN
ELSE α BLK_NAME←NULL; REJECT←TRUE; β;
PRINT(TT);
SPACING←SPACING+1;
WHILE ¬EQU(TOKEN,E1) DO
α
P_STATEMENT;
GET_TOKEN;
IF TYPE_OF_RES_WORD≠end_RES
THEN ERROR_REJECT(4,
"Need semicolon before this token ⊂"&TOKEN&"⊃")
ELSE IF EQU(TOKEN,E2) THEN
α
ERROR(5,"Block ends with " & E2 & cr
& "Continue will view as "& E1);
TOKEN←E1;
β;
β;
GET_TOKEN;
IF TYPE_OF_TOKEN=STRING_TOKEN AND TOKEN_PTR=NULL_RECORD
THEN BLK_NAME_END←TOKEN
ELSE α BLK_NAME_END←NULL; REJECT←TRUE; β;
IF ¬(EQU(BLK_NAME,BLK_NAME_END) OR EQU(BLK_NAME_END,NULL))
THEN ERROR(600, "Block name at end does not agree with that at beginning.");
UNUSED_S←NULL;
IFC DEFIN_PRINT_SWITCH THENC UNDEFINED_S←NULL; ENDC;
FOR I←1 STEP 1 UNTIL DEC_NUM DO
α STRING SS;
SYMBOL_TABLE[HASH(SS←ID_LIST:NAME[TOP_ID],id_hasher)]
← ID_LIST:NEXT[TOP_ID];
IF ¬USED(TOP_ID) THEN UNUSED_S←UNUSED_S&CRLF& "⊂"&SS&
"⊃ DECLARED ON PAGE "
&CVS(ID_PAGE(TOP_ID))& " LINE "
&CVS(ID_LINE(TOP_ID));
IFC DEFIN_PRINT_SWITCH THENC
IF ¬DEFINED(TOP_ID) THEN UNDEFINED_S←UNDEFINED_S&CRLF&"⊂"&SS&
"⊃ DECLARED ON PAGE "
&CVS(ID_PAGE(TOP_ID))& " LINE "
&CVS(ID_LINE(TOP_ID));
ENDC
TOP_ID←ID_LIST:LAST[RR←TOP_ID];
$REC$(5,RR);
β;
IF LENGTH(UNUSED_S)≠0 THEN UNUSED_S←UNUSED_S&
CRLF & " WERE NEVER USED";
IFC DEFIN_PRINT_SWITCH THENC
IF LENGTH(UNDEFINED_S)≠0 THEN UNUSED_S←UNUSED_S&CRLF & UNDEFINED_S &
CRLF & " WERE NEVER DEFINED";
ENDC
IF LENGTH(UNUSED_S)≠0 THEN ERROR(-1,UNUSED_S);
FOR I←1 STEP 1 UNTIL MACRO_DEC_NUM DO
α
MACRO_TABLE[HASH(MACRO_LIST:ID[TOP_MACRO],macro_hasher)]
←MACRO_LIST:NEXT[TOP_MACRO];
TOP_MACRO←MACRO_LIST:LAST[RR←TOP_MACRO];
$REC$(5,RR);
β;
FOR I←1 STEP 1 UNTIL DIMEN_DEC_NUM DO
α
DIMENS_TABLE[HASH(DIMENS_EXPONENT:NAME[TOP_DIMENS],metric_hasher)]
←DIMENS_EXPONENT:NEXT[TOP_DIMENS];
TOP_DIMENS←DIMENS_EXPONENT:LAST[rr←TOP_DIMENS];
$REC$(5,RR);
β;
DEC_NUM←SAVE_DEC_NUM;
MACRO_DEC_NUM←SAVE_MACRO_DEC_NUM;
DIMEN_DEC_NUM←SAVE_DIMEN_DEC_NUM;
SPACING←SPACING-1;
BLOCK_LEVEL←BLOCK_LEVEL-1;
PRINT(")");
β;
procedure end_P;
α ! SEMICOLON FOUND - NOOP;
REJECT←TRUE;
β;
procedure open_paren_P;
α INTEGER C; STRING TEMP;
! LEFT PAREN FOUND - STAIGHT TRANSFER;
C←1;
TEMP←"(";
WHILE C>0 DO
α
TEMP←TEMP&READ(paren_cr_break);
IF BRCHAR="(" THEN C←C+1
ELSE IF BRCHAR=")" THEN C←C-1 ELSE
α
PRINT(TEMP);
TEMP←NULL;
β;
β;
PRINT(TEMP);
β;
! define_P,declare_P,global_P;
procedure define_P;
if ¬macro_handler then goto FLUSH;
FORWARD STRING PROCEDURE declare2_P;
procedure declare_P;
α
STRING BUILD_OUT;
INSIDE_DECLARE_P←TRUE;
BUILD_OUT←declare2_P;
INSIDE_DECLARE_P←FALSE;
IF TOKEN≠";" THEN ERROR(23,"Need semicolon here");
REJECT←TRUE;
PRINT(BUILD_OUT&")");
β;
procedure global_P;
α RPTR(DIMENS_EXPONENT) O_DIM; O_DIM←DIM_PTR;
INSIDE_DECLARE_P←TRUE;
PRINT("("&LABL&"GVAR"); SPACING←SPACING+1; GET_TOKEN;
WHILE ¬EQU(TOKEN,";") DO
α STRING BUILD_OUT;
IF TYPE_OF_TOKEN=metric_TOKEN
THEN IF O_DIM=NULL_RECORD
THEN α DIM_PTR←TOKEN_PTR; GET_TOKEN; β
ELSE F_STATE(0,34,"Global declaration already declared")
ELSE DIM_PTR←O_DIM;
IF TYPE_OF_RES_WORD≠declare_RES THEN F_STATE(1,8, "Need variable type here.");
BUILD_OUT←declare2_P;
PRINT(BUILD_OUT&")");
β;
REJECT←TRUE;
SPACING←SPACING-1;
PRINT(")");
INSIDE_DECLARE_P←FALSE;
β;
STRING procedure declare2_P;
α
STRING BUILD_OUT; INTEGER TYPE1;
INTEGER SI;
RPTR(DIMENS_EXPONENT) DIM; LABEL RE_TRY;
procedure default_metric;
CASE SPECIAL_INFO OF
α
[scalar_VALUE]
[plane_VALUE]
[trans_VALUE]
[vector_VALUE] DIM←NIL_DIMENS;
[rot_VALUE] DIM←ANGLE_DIMENS;
[frame_VALUE] DIM←DISTANCE_DIMENS;
ELSE DIM←NULL_RECORD
β;
procedure check_metric;
IF SPECIAL_INFO≠VECTOR_VALUE AND special_info≠SCALAR_VALUE
THEN IF DIM≠null_record
THEN ERROR(3000,TOKEN &" cannot take arbitrary dimensions");
SI←SPECIAL_INFO;
ERROR_BUFFER←CURLINER;
DIM←DIM_PTR;
RE_TRY:
check_metric;
IF DIM=NULL_RECORD THEN DEFAULT_METRIC;
BUILD_OUT←"("&LABL&DEC_NAME[SI];
IF SI≠frame_VALUE
THEN TYPE1←SPECIAL_INFO ELSE TYPE1←trans_VALUE;
GET_TOKEN;
WHILE ¬EQU(TOKEN,";") AND TYPE_OF_TOKEN≠metric_TOKEN AND TYPE_OF_RES_WORD≠DECLARE_RES DO
α RPTR (ID_LIST) POINT;
IF TYPE_OF_TOKEN=reserved_token
THEN α WHILE TYPE_OF_TOKEN=reserved_token
do α string s1; s1←"⊂"&TOKEN&"⊃ is a reserved word";
MODIFY_continue(3000,s1); β;
β
ELSE IF BLOCK_LEVEL_OF_DEFN=BLOCK_LEVEL
THEN MODIFY_CONTINUE_MACRO([3001,"⊂"&TOKEN&"⊃ is multiply defined "
&"in this block."])
ELSE IF BLOCK_LEVEL_OF_DEFN=0
THEN MODIFY_CONTINUE_MACRO([3002,"⊂"&TOKEN&"⊃ is a predeclared constant."]);
BUILD_OUT←BUILD_OUT&" "&TOKEN;
POINT←INSERT_ENTRY(TOKEN,ID_TYPE_TABLE);
ID_LIST:TYPE[POINT]←TYPE1;
ID_LIST:DIMEN[POINT]←DIM;
GET_TOKEN;
IF EQU(TOKEN,";") OR TYPE_OF_TOKEN=metric_TOKEN OR TYPE_OF_RES_WORD=declare_RES
THEN REJECT←TRUE
ELSE IF ¬EQU(TOKEN,",") THEN
ERROR_REJECT(7,"Missing comma.");
GET_TOKEN;
β;
return(build_out);
β;
! if_P, plan_P, while_P;
procedure if_P;
α ! IF STATEMENT FOUND;
IF PLAN_STATEMENT THEN PRINT("("&LABL&"CIF") ELSE PRINT("("&LABL&"IF");
PLAN_STATEMENT←FALSE;
SPACING←SPACING+1;
P_EXP;
IF EXP_TYPE≠boole_VALUE AND EXP_TYPE≠scalar_VALUE
THEN F_STATE(1,10,"Conditional for IF must be boolean");
GET_TOKEN;
IF ¬EQU(TOKEN,"THEN") THEN
ERROR_REJECT(9,"Missing THEN. Continue will insert it.");
P_STATEMENT;
GET_TOKEN;
IF EQU(TOKEN,"ELSE") THEN P_STATEMENT ELSE REJECT←TRUE;
SPACING←SPACING-1;
PRINT(")");
β;
procedure plan_P;
α ! PLAN STATEMENT FOUND;
LABEL RE_TRY;
ERROR_BUFFER←CURLINER;
GET_TOKEN;
RE_TRY:
IF ¬(EQU(TOKEN,"IF") OR EQU(TOKEN,"WRITE") OR EQU(TOKEN,"ERROR")
OR EQU(TOKEN,"FOREACH")) THEN MODIFY_FLUSH_MACRO([0,11,"Illegal token to "&
"follow PLAN: "&TOKEN]);
REJECT←TRUE;
PLAN_STATEMENT←TRUE;
P_STATEMENT;
PLAN_STATEMENT←FALSE;
β;
procedure while_P;
α ! WHILE STATEMENT FOUND;
PRINT("("&LABL&"WH");
SPACING←SPACING+1;
P_EXP;
IF EXP_TYPE≠boole_VALUE AND EXP_TYPE≠scalar_VALUE
THEN F_STATE(0,11,"Conditional for WHILE must be boolean or sclar.");
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN
ERROR_REJECT(12,"Missing DO. Continue will insert it.");
P_STATEMENT;
SPACING←SPACING-1;
PRINT(")");
β;
! for_P;
procedure for_P;
α RPTR(ID_LIST) POINT;RPTR(DIMENS_EXPONENT)POINTD; ! FOR STATEMENT FOUND;
LABEL RE_TRY;
ERROR_BUFFER←CURLINER;
GET_TOKEN;
RE_TRY:
IF TYPE_OF_TOKEN=undeclared_token
THEN
α MODIFY_BACKUP_CONTINUE_MACRO([0,"Undeclared variable "&TOKEN&" declared a scalar"]);
POINT←INSERT_ENTRY(TOKEN,ID_TYPE_TABLE);
ID_LIST:TYPE[POINT]←scalar_VALUE;
ID_LIST:DIMEN[POINT]←NIL_DIMENS;
PRINT("(SVAR "&TOKEN&")");
β
ELSE
α POINT←TOKEN_PTR;
IF TYPE_OF_TOKEN≠id_token OR ID_TYPE≠scalar_value
THEN MODIFY_BACKUP_CONTINUE_MACRO([1300, "Need scalar ID here."]);
β;
PRINT("("&LABL&"FO "&ID_LIST:NAME[POINT]);
POINTD←ID_LIST:DIMEN[POINT];
USE(POINT); DEFIN(POINT);
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"←") THEN
ERROR_REJECT(14,"Need left arrow here for FOR statement.");
P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,POINTD,
"DUMMY variable in FOR statement")
THEN ERROR_REJECT(15,"Need scalar value here.");
GET_TOKEN;
IF ¬EQU(TOKEN,"STEP") THEN
ERROR_REJECT(16,"Need STEP here.");
P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,POINTD,
"DUMMY variable in FOR statement")
THEN ERROR_REJECT(15,"Need scalar value here.");
GET_TOKEN;
IF ¬EQU(TOKEN,"UNTIL") THEN
ERROR_REJECT(17,"Need UNTIL here.");
P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,POINTD,
"DUMMY variable in FOR statement")
THEN ERROR_REJECT(15,"Need scalar value here.");
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN
ERROR_REJECT(18,"Need DO here.");
P_STATEMENT;
SPACING←SPACING-1;
PRINT(")");
β;
! move_P;
procedure move_P;
α RPTR(ID_LIST) POINT; ! MOVE STATEMENT FOUND;
LABEL RE_TRY;
ERROR_BUFFER←CURLINER;
GET_TOKEN;
RE_TRY:
IF TYPE_OF_TOKEN≠ID_TOKEN OR ID_TYPE≠TRANS_VALUE
THEN MODIFY_BACKUP_CONTINUE_MACRO([19,"Need frame ID here."]);
CURRENT_FRAME←TOKEN;
PRINT("("&LABL&"MO "&TOKEN);
SPACING←SPACING+1;
IF ¬CHECK_NEXT_TOKEN(19,NULL,"TO") THEN REJECT←TRUE;
P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(trans_VALUE,DISTANCE_DIMENS, "FRAME Expression")
THEN ERROR_REJECT(20,"Need either a FRAME or TRANSFORM expression here.");
CURRENT_FRAME←null;
P_CLAUSES;
SPACING←SPACING-1;
PRINT(")");
β;
! affix_p,unfix_p;
procedure affix_p;
α STRING SAVE1,SAVE2,TRANS; RPTR(ID_LIST) POINT;
! AFFIX STATEMENT FOUND;
LABEL RE_TRY;
ERROR_BUFFER←CURLINER;
GET_TOKEN;
RE_TRY:
IF TYPE_OF_TOKEN≠ID_TOKEN OR ID_TYPE≠TRANS_VALUE
THEN α MODIFY_BACKUP_CONTINUE_MACRO([19,"Need frame ID here."]) ELSE
POINT←INSERT_ENTRY(TOKEN,ID_TYPE_TABLE); β
ELSE POINT←TOKEN_PTR;
DEFIN(POINT); AFFIX(POINT);
CURRENT_FRAME←SAVE1←TOKEN;
IF ¬CHECK_NEXT_TOKEN(21,NULL,"TO") THEN REJECT←TRUE;
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token
THEN POINT←ERROR_REJECT(13,"Need frame ID here.")
ELSE α POINT←TOKEN_PTR; IF ID_TYPE≠trans_VALUE THEN ERROR(19,"Need frame ID here."); β;
IF ¬DEFINED(POINT) THEN UNDEFINED_VAR;
AFFIX(POINT);
SAVE2←TOKEN; GET_TOKEN;
IF EQU(TOKEN,"BY")
THEN
α GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token
THEN POINT←ERROR(13,"Need frame ID here.")
ELSE
α POINT←TOKEN_PTR;
IF ID_TYPE≠trans_VALUE
THEN ERROR(19,"Need frame ID here.");
β;
IF ¬DEFINED(POINT) THEN UNDEFINED_VAR;
TRANS←TOKEN;
β
ELSE α TRANS←T_GEN; PRINT("(TVAR "&TRANS&")"); REJECT←TRUE; β;
GET_TOKEN;
IF EQU(TOKEN,"AT")
THEN
α PRINT("("&LABL&"AFFIX "&SAVE1&" "&SAVE2&" "&TRANS);
SPACING←SPACING+1; P_EXP; GET_TOKEN;
IF EQU(TOKEN,"RIGIDLY")
THEN PRINT("RIGIDLY)")
ELSE IF EQU(TOKEN,"NONRIGIDLY")
THEN PRINT("NONRIGIDLY)")
ELSE α PRINT("NONRIGIDLY)");REJECT←TRUE; β;
SPACING←SPACING-1;
β
ELSE
α STRING HOW;
IF TOKEN_EQU("RIGIDLY","NONRIGIDLY")
THEN HOW←TOKEN
ELSE α HOW←"NONRIGIDLY";REJECT←TRUE;β;
PRINT("("&LABL&"AFFIX "&SAVE1&" "&SAVE2&" "&TRANS&" () "&HOW&")");
β;
CURRENT_FRAME←null;
β;
procedure unfix_P;
α STRING SAVE1; RPTR(ID_LIST) POINT; ! UNAFFIX STATEMENT FOUND;
LABEL RE_TRY;
ERROR_BUFFER←CURLINER;
RE_TRY:
GET_TOKEN;
IF TYPE_OF_TOKEN≠ID_TOKEN OR ID_TYPE≠TRANS_VALUE
THEN α MODIFY_BACKUP_CONTINUE_MACRO([19,"Need frame ID here."]) ELSE
POINT←INSERT_ENTRY(TOKEN,ID_TYPE_TABLE); β
ELSE POINT←TOKEN_PTR;
IF ¬DEFINED(POINT) THEN UNDEFINED_VAR;
IF ¬AFFIXED(POINT) THEN UNAFFIXED_VAR;
CURRENT_FRAME←SAVE1←TOKEN;
IF ¬CHECK_NEXT_TOKEN(20,NULL,"FROM") THEN REJECT←TRUE;
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token
THEN POINT←ERROR(13,"Need frame ID here.")
ELSE IF ID_TYPE≠trans_VALUE
THEN ERROR(19,"Need frame ID here.");
IF ¬DEFINED(POINT) THEN UNDEFINED_VAR;
PRINT("("&LABL&"UNFIX"&" "&SAVE1&" "&TOKEN&")"); CURRENT_FRAME←null;
β;
! signal_p, wait_p;
procedure signal_wait_P(boolean ws);
α STRING WS_SIGN; LABEL RE_TRY;
ERROR_BUFFER←CURLINER;
IF WS THEN WS_SIGN←" -)" ELSE WS_SIGN←" +)";
GET_TOKEN;
RE_TRY:
IF TYPE_OF_TOKEN≠id_token OR ID_TYPE≠event_VALUE
THEN MODIFY_BACKUP_CONTINUE_MACRO([19,"Need event ID here."]);
PRINT("("&LABL&"EV "&TOKEN&WS_SIGN);
DEFIN(TOKEN_PTR);
β;
procedure signal_P;
signal_wait_P(FALSE); ! SIGNAL STATEMENT FOUND;
procedure wait_P;
signal_wait_P(TRUE); ! WAIT STATEMENT FOUND;
! when_P;
procedure when_P;
α RPTR (ID_LIST) POINT; STRING VAR, ALSO_OP, CHG_LAB;
BOOLEAN TEMP; LABEL RE_TRY;
! WHEN STATEMENT FOUND;
ERROR_BUFFER←CURLINER;
GET_TOKEN;
RE_TRY:
IF ¬EQU(TOKEN,"CHANGING") THEN
ERROR_REJECT(30,"Need word CHANGING here for a WHEN CHANGING statement."&
" Continue will insert it.");
GET_TOKEN;
IF TYPE_OF_TOKEN=undeclared_token THEN MODIFY_BACKUP_CONTINUE_MACRO([31,"Undefined ID"]);
VAR←TOKEN; GET_TOKEN;
IF EQU(TOKEN,"ALSO")
THEN ALSO_OP←"ALSO_DO"
ELSE IF EQU(TOKEN,"DON'T")
THEN ALSO_OP←"ALSO_DON'T"
ELSE IF EQU(TOKEN,"ONLY")
THEN ALSO_OP←"ALSO_ONLY"
ELSE MODIFY_CONTINUE_MACRO([32,"Illegal ALSO_OP"]);
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN ERROR_REJECT(33,"Need DO here. Continue will insert it.");
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token
THEN TEMP←TRUE
ELSE IF ID_TYPE=ch_label_VALUE
THEN TEMP←FALSE
! ?????; ELSE IF ID_TYPE>world_VALUE
THEN
α ERROR(34,"Can only handle CH_LABEL here. Continue while delete this label.");
TEMP←TRUE;
β
ELSE TEMP←TRUE;
IF TEMP
THEN
α CHG_LAB←T_GEN; PRINT("(CHGLAB "&CHG_LAB&")"); REJECT←TRUE;
CHANGER_HEAD←CHG_LAB&" CHG ";
β
ELSE
α CHG_LAB←TOKEN; GET_TOKEN;
IF EQU(TOKEN,":")
THEN α TEMP←TRUE; CHANGER_HEAD←CHG_LAB&" CHG "; β
ELSE α REJECT←TRUE; PRINT("("&ALSO_OP&" "&VAR&" "&CHG_LAB&")"); β;
β;
IF TEMP
THEN
α PRINT("("&ALSO_OP&" "&VAR); SPACING←SPACING+1; P_STATEMENT;
SPACING←SPACING-1; PRINT(")");
β;
β;
! dump_P;
procedure dump_P;
α RPTR (ID_LIST) POINT; STRING IDSTRING;
! DUMP STATEMENT FOUND;
IDSTRING←null; GET_TOKEN;
IF ID_TYPE=world_VALUE
THEN PRINT("("&LABL&"DBD "&TOKEN&")")
ELSE
α
DO α
IF TYPE_OF_TOKEN≠ID_TOKEN OR ID_TYPE>event_VALUE THEN ERROR(35,"Undefined ID.");
IDSTRING←IDSTRING&" "&TOKEN;GET_TOKEN;
IF ¬EQU(TOKEN,"IN") OR TOKEN≠";"
THEN
α IF TOKEN≠","
THEN ERROR_REJECT(36, "Need comma or IN or ; here. Continue will insert it.");
GET_TOKEN;
β;
β
UNTIL EQU(TOKEN,"IN") OR EQU(TOKEN,";");
IF EQU(TOKEN,"IN")
THEN
α GET_TOKEN;
IF ID_TYPE≠world_VALUE
THEN ERROR(37,"Need a world ID here.")
ELSE IDSTRING←IDSTRING & " " & TOKEN;
β;
PRINT ("("&LABL&"PVL "&IDSTRING&")");
β;
β;
! assert_P;
procedure assert_P;
α RPTR (ID_LIST) POINT; STRING IDSTRING,COM;INTEGER VAR_TYPE;
! ASSERT OR DENY STATEMENT FOUND;
COM←TOKEN; GET_TOKEN;
IF EQU(TOKEN,"FORM")
THEN
α IDSTRING←null; GET_TOKEN;
IF ¬EQU(TOKEN,"(")
THEN ERROR_REJECT(37,"Need left paren here. Continue will insert it.");
WHILE ¬EQU(TOKEN,")")
DO α
GET_TOKEN; IDSTRING←IDSTRING&TOKEN&" "; GET_TOKEN;
IF ¬EQU(TOKEN,")") AND ¬EQU(TOKEN,",")
THEN ERROR_REJECT(38,"Need either comma or right paren here."&
" Continue will insert a comma.");
β;
GET_TOKEN;
IF EQU(TOKEN,"IN")
THEN
α GET_TOKEN;
IF ID_TYPE≠world_VALUE THEN ERROR(39,"Need world ID here.");
PRINT("("&LABL&COM&" (SF "&IDSTRING&") "&TOKEN&")");
β
ELSE α REJECT←TRUE; PRINT("("&LABL&COM&" (SF "&IDSTRING&"))"); β;
β
ELSE
α STRING VAR;
! ?????; IF TYPE_OF_TOKEN≠ID_TOKEN OR ID_TYPE>trans_VALUE
THEN
α ERROR(40,"Need variable ID here.");
POINT←SYMBOL_TABLE[HASH("GARB_ID",id_hasher)];
β
ELSE POINT←TOKEN_PTR;
VAR_TYPE←ID_TYPE;GET_TOKEN;
IF ¬EQU(TOKEN,"=")
THEN ERROR(41,"Sorry, can only handle equality right now.");
PRINT("("&LABL&COM&" (AF "&VAR&" = "); SPACING←SPACING+1;
P_EXP; SPACING←SPACING-1;
IF VAR_TYPE≠EXP_TYPE THEN ERROR(42,"Types don't match on equality test.");
GET_TOKEN;
IF EQU(TOKEN,"IN")
THEN
α GET_TOKEN;
IF TYPE_OF_TOKEN≠ID_TOKEN OR ID_TYPE≠world_VALUE THEN ERROR(39,"Need world ID here.");
PRINT(") "&TOKEN&")");
β
ELSE α REJECT←TRUE; PRINT("))"); β;
β;
β;
! on_P, reference_P;
procedure on_P;
α RPTR (ID_LIST) POINT;
! CONDITION MONITER FOUND;
BOOLEAN ICMT;
ICMT←INSIDE_CONDITION_MONITOR;
IF ¬EQU(LABL,null)
THEN
IF LABEL_TYPE≠cm_label_VALUE
THEN
α
ERROR(43,"Must have condition monitor label if any label is uesed. Continue will flush label.");
LABL←null;
β;
INSIDE_CONDITION_MONITOR←TRUE;
IF EQU(TOKEN,"ON") THEN P_CONDITION(0,"( "&LABL&"ON +")
ELSE α CHECK_NEXT_TOKEN(27,null,"ON"); P_CONDITION(0,"("&LABL&"ON -"); β;
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN
ERROR_REJECT(45,"Need DO here. Continue will insert it.");
P_STATEMENT;
INSIDE_CONDITION_MONITOR←ICMT;
SPACING←SPACING-1;
PRINT(")");
β;
procedure reference_P;
α RPTR (ID_LIST) POINT; ! NEW WORLD DEF;
GET_TOKEN;
IF ¬EQU(TOKEN,"POINT") THEN
ERROR_REJECT(46,"Need POINT here for a REFERENCE POINT statement.");
GET_TOKEN;
POINT←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE);
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠world_VALUE THEN
ERROR(47,"Need a world variable here.");
PRINT("("&LABL&"NW "&TOKEN&")");
β;
! open_P,center_P,stop_P,enable_P,disable_P;
procedure open_P;
α STRING HAND; ! OPEN/CLOSE FOUND;
RPTR (ID_LIST) POINT;
check_next_token(48,"Unknown hand in OPEN/CLOSE statement",
"BHAND","YHAND"); HAND←TOKEN;
check_next_token(49,NULL,"TO");
PRINT("("&LABL&"MO "&HAND);
SPACING←SPACING+1;
P_EXP;
IF ¬CHECK_EXP_TYPE_DIMENS(scalar_VALUE,DISTANCE_DIMENS,
"OPEN/CLOSE statement")
THEN ERROR(121,"Need scalar quantity here.");
SPACING←SPACING-1;
PRINT(")");
β;
procedure center_P;
IF check_next_token(50,"Unknown arm in CENTER statement",
"BARM","YARM") then PRINT("("&LABL&"CENTER "&TOKEN&")");
procedure stop_P;
α ! STOP FOUND;
RPTR(ID_LIST) R1;
GET_TOKEN;
IF (R1←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE))≠NULL_RECORD
THEN α IF (ID_LIST:TYPE[R1]≠TRANS_VALUE)
THEN ERROR(49, "Trying to stop a non-frame");
PRINT("("&LABL&"STOP "&TOKEN&")");
β
ELSE α IF TYPE_OF_TOKEN = undeclared_token
THEN PRINT("("&LABL&" STOP "&TOKEN&")")
ELSE α REJECT←TRUE; PRINT("("&LABL&"STOP )");β;
β;
β;
procedure denable_P(boolean en);
α ! ENABLE/DISABLE found;
STRING S1;
s1← "(" & LABL & " CMABLE " & ( if en then " + " else " - ");
GET_TOKEN;
IF ID_TYPE = CM_LABEL_VALUE
THEN α S1← S1&TOKEN&" )"; USE(TOKEN_PTR); β
ELSE α REJECT←TRUE; IF INSIDE_CONDITION_MONITOR
THEN S1 ← S1 & " )"
ELSE ERROR(123, "Need CM label here.");
β;
PRINT(S1);
β;
procedure enable_P;
denable_P(true);
procedure disable_P;
denable_P(false);
! require_P;
procedure require_P;
α ! REQUIRE STATEMENT FOUND;
LABEL RE_TRY;
ERROR_BUFFER←CURLINER;
GET_TOKEN;
RE_TRY:
IF ¬(require_beg ≤ TYPE_OF_RES_WORD ≤ require_end)
THEN α IF MODIFY_FLUSH(0,51,"Illegal token after REQUIRE") THEN GOTO RE_TRY; β
ELSE
CASE TYPE_OF_RES_WORD - require_beg OF
α
[source_file_X] α
string new_file;
GET_TOKEN;
new_file←token;
GET_TOKEN;
REJECT←TRUE;
TOP_SOURCE←PUSH_SOURCE_LIST(TOP_SOURCE);
SOURCE_LIST:NUM[TOP_SOURCE]←0;
WHILE ¬ got_input(PRESENT_file←open_new_file(new_file))
DO α ERROR(55,"FILE NOT AVAILABLE");
new_file←infile; β;
CHANIN←file:chn[PRESENT_FILE];
if equ(file:device[PRESENT_file],"TTY")
then
α
CHECK_WANT_COPY;
OUTSTR(CRLF&"Enter input through the keyboard. Terminate with<CONTROL><META><LF>"&CRLF);
β
else
α if typed_page_num then outstr(crlf);
outstr(infile & " 1");
β;
β;
[delimiters_X] α RPTR (DELIMITER_LIST) NEW_DEL;
GET_TOKEN;
IF TYPE_OF_TOKEN≠string_token OR LENGTH(TOKEN)≠2
THEN MODIFY_BACKUP_FLUSH_MACRO([0,53,"Need string of length 2."]);
push_delimiters(token);
β;
[unstack_delimiters_X] IF NULL=TOP_DELIMITERS
THEN F_STATE(0,54,"Sorry, delimiter stack empty.")
ELSE TOP_DELIMITERS←DELIMITER_LIST:NEXT[TOP_DELIMITERS];
[replace_delimiters_X] α
GET_TOKEN;
IF TYPE_OF_TOKEN≠string_token OR LENGTH(TOKEN)≠2
THEN MODIFY_BACKUP_FLUSH_MACRO([0,53,"Need string of length 2."]);
delimiter_list:d1[top_delimiters] ← lop(token);
delimiter_list:d2[top_delimiters] ← lop(token);
β;
[message_x] α
GET_TOKEN;
IF TYPE_OF_TOKEN≠string_token
THEN MODIFY_BACKUP_FLUSH_MACRO([0,52,"Need string here"]);
OUTSTR(TOKEN);
β;
[error_modes_x] α
INTEGER I,L; STRING S; BOOLEAN T;
GET_TOKEN;
IF TYPE_OF_TOKEN≠string_token
THEN MODIFY_BACKUP_FLUSH_MACRO([0,52,"Need string here"]);
L←length(token);
FOR I←1 STEP 1 UNTIL L DO
α S←TOKEN[I FOR 1];
IF EQU(S,"-") THEN α I←I+1;
S←TOKEN[I FOR 1];
T←FALSE;
β
ELSE T←TRUE;
IF EQU(S,"L")
THEN α COMPILE_LOGGING←T; IF ¬T THEN LOGGING←T; β
ELSE IF EQU(S,"A")
THEN AUTO_PROCEED←T
ELSE IF EQU(S,"F")
THEN STRICT_DIMEN_CHECK←T
ELSE IF EQU(S,"M")
THEN PROMPT_FOR_MODIFIABLE_ERROR_ONLY←T
ELSE ERROR(0,"Error_mode " & s & " undefined.");
β;
β;
[compiler_switches_x] α
INTEGER I,L,I1; STRING S; BOOLEAN NON_EXIST_SWITCH,BAIL_WANTED;
GET_TOKEN;
IF TYPE_OF_TOKEN≠string_token
THEN F_STATE(0,52,"Need string here.");
L←LENGTH(TOKEN);
FOR I←1 STEP 1 UNTIL L DO
α
S←TOKEN[I FOR 1];
NON_EXIST_SWITCH←TRUE;
FOR I1←0 STEP 1 UNTIL SWITCH_MAX DO
IF EQU(S,SWITCH_NAME[I1]) THEN
α SWITCH_SETTING[I1]←TRUE;
IF I1=B_X THEN BAIL_WANTED←TRUE;
NON_EXIST_SWITCH←FALSE;
β;
IF NON_EXIST_SWITCH THEN
ERROR(0,"Switch " & S & " unknown");
β;
IF BAIL_WANTED
THEN α
IFC debug_compile
THENC OUTSTR(crlf & "BAIL requested"); BAIL
ELSEC OUTSTR("Sorry, Bail not loaded." & crlf)
ENDC;
β;
β;
[comment_delimiters_x] α
STRING CLOSE_BRACE;
GET_TOKEN;
IF TYPE_OF_TOKEN≠string_token OR LENGTH(TOKEN)≠2
THEN MODIFY_BACKUP_FLUSH_MACRO([0,53,"Need string of length 2."]) ;
OPEN_BRACE←TOKEN[1 FOR 1];
CLOSE_BRACE←TOKEN[2 FOR 1];
SETBREAK(close_brace_break, CLOSE_BRACE, NULL, "ISK");
add_to_table1(token);
β;
[bail_X] α
IFC debug_compile
THENC OUTSTR(crlf & "BAIL requested"); BAIL
ELSEC OUTSTR("Sorry, Bail not loaded." & crlf)
ENDC;
β
β;
β;
! dimension_P;
procedure dimension_P;
α "dimen_p"
! DIMENSION STATEMENT FOUND;
STRING DIMEN_NAME;LABEL RE_TRY;
RPTR(DIMENS_EXPONENT) D1,temp;
BOOLEAN TOP; INTEGER COUNT;
RCLASS DIMEN_REDUCE(STRING OP; RPTR (DIMEN_REDUCE) LAST;
RPTR (DIMENS_EXPONENT) DIM_PTR);
RPTR (DIMEN_REDUCE) CURRENT,CUR2;
string cur_op;
ERROR_BUFFER←CURLINER;
RE_TRY:
TOP←TRUE; COUNT←0;
CUR_OP←NULL;
GET_TOKEN;
IF TYPE_OF_TOKEN≠undeclared_token AND BLOCK_LEVEL_OF_DEFN=BLOCK_LEVEL
THEN MODIFY_BACKUP_FLUSH_MACRO([0,61,"Can only use unreserved ID's for dimensions."]);
DIMEN_NAME←TOKEN;
GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(62,"Need = here.");
GET_TOKEN;
CURRENT←NULL_RECORD;
DIM_PTR←NIL_DIMENS;
WHILE TOKEN≠";" DO
α
WHILE EQU(TOKEN,"INV") OR EQU(TOKEN,"(") OR EQU(TOKEN , ")") OR
EQU(TOKEN,"*") OR EQU(TOKEN,"/") DO
α
IF EQU(TOKEN,"INV") THEN
α CUR2←NEW_RECORD(DIMEN_REDUCE);
DIMEN_REDUCE:OP[CUR2]←"INV";
DIMEN_REDUCE:LAST[CUR2]←CURRENT;
DIMEN_REDUCE:DIM_PTR[CUR2]←DIM_PTR;
DIM_PTR←NIL_DIMENS;
CURRENT←CUR2;
GET_TOKEN;
IF ¬EQU(TOKEN,"(") THEN ERROR_REJECT(63,"Need ( here");
COUNT←COUNT+1;
GET_TOKEN;
IF EQU(TOKEN,"/") OR EQU(TOKEN,"*") THEN ERROR
(64, "Can`t have "&token&" after (.");
β
ELSE IF EQU(TOKEN,"(") THEN
α CUR2←NEW_RECORD(DIMEN_REDUCE);
DIMEN_REDUCE:OP[CUR2]←CUR_OP;
cur_op←null;
COUNT←COUNT+1;
DIMEN_REDUCE:LAST[CUR2]←CURRENT;
DIMEN_REDUCE:DIM_PTR[CUR2]←DIM_PTR;
DIM_PTR←NIL_DIMENS;
CURRENT←CUR2;
GET_TOKEN;
IF EQU(TOKEN,"/") OR EQU(TOKEN,"*") THEN ERROR
(64, "Can`t have "&token&" after (.");
β
ELSE IF EQU(TOKEN, "*") or equ(token,"/") THEN
α
CUR_OP←TOKEN;
GET_TOKEN;
IF EQU(TOKEN,"*") OR EQU(TOKEN,"/") OR EQU(TOKEN,")")
THEN ERROR(64, "Can't have "&token&" after "&cur_op);
β
ELSE IF EQU(TOKEN,")") THEN
α
if count≤0 then F_STATE(0,65, "Right paren without left paren.")else
IF EQU(DIMEN_REDUCE:OP[CURRENT],"*") THEN
DIM_PTR←MULTIPLY_DIMENSIONS(DIM_PTR,
DIMEN_REDUCE:DIM_PTR[CURRENT])
ELSE IF EQU(DIMEN_REDUCE:OP[CURRENT],"/") THEN
DIM_PTR←DIVIDE_DIMENSIONS(
DIMEN_REDUCE:DIM_PTR[CURRENT],DIM_PTR)
ELSE IF EQU(DIMEN_REDUCE:OP[CURRENT],"INV") THEN
DIM_PTR←INVERSE_DIMENSIONS(DIM_PTR)
ELSE IF DIMEN_REDUCE:OP[CURRENT]≠NULL THEN
ERROR(66, "Can't do this");
CURRENT←DIMEN_REDUCE:LAST[CURRENT];
COUNT←COUNT-1;
IF CURRENT≠NULL_RECORD THEN cur_op←dimen_reduce:op[current]
ELSE CUR_OP←NULL;
GET_TOKEN;
IF EQU(TOKEN,"(") THEN ERROR(64,"Can't have ( after )");
β;
β;
IF TOKEN≠";" THEN
α
D1←CHECK_ENTRY(TOKEN,DIMENSION_TYPE_TABLE);
IF D1=NULL_RECORD THEN ERROR(0000, TOKEN & "not declared.")
ELSE IF EQU(CUR_OP,"*") THEN
DIM_PTR←MULTIPLY_DIMENSIONS(DIM_PTR,D1)
ELSE IF EQU(CUR_OP,"/") THEN
DIM_PTR←DIVIDE_DIMENSIONS(DIM_PTR,D1)
ELSE IF CUR_OP=NULL THEN
DIM_PTR←D1
ELSE ERROR(1234, "Can't do this");
CUR_OP←NULL;
GET_TOKEN;
β;
β;
IF COUNT≠0 THEN MODIFY_FLUSH(0,65,"Parens don't match.");
if current≠ null_record then error(1112,"Incomplete evaluation");
D1←DIM_PTR;
IF D1=NULL OR D1=NIL_DIMENS THEN
insert_entry(DIMEN_NAME,DIMENSION_TYPE_TABLE)
ELSE INSERT_ENTRY(DIMEN_NAME,DIMENSION_TYPE_TABLE,D1);
REJECT←TRUE;
β "dimen_p";
! string_P, integer_P;
procedure string_P;
α
BOOLEAN NEW;RPTR(ID_LIST)R1; LABEL RE_TRY;
INSIDE_STRING_DECLARATION←TRUE;
IF EQU(TOKEN,"NEW_STRING") THEN NEW←TRUE ELSE NEW←FALSE;
ERROR_BUFFER←CURLINER;
GET_TOKEN;
RE_TRY:
R1←TOKEN_PTR;
IF NEW
THEN α IF R1=NULL_RECORD OR ID_LIST:BLOCK_LEVEL_OF_DEFN[R1]≠BLOCK_LEVEL
THEN r1←insert_entry(token,id_type_table)
ELSE MODIFY_BACKUP_CONTINUE_MACRO([ 12,TOKEN &" already defined"]);
β
ELSE IF R1=NULL_RECORD
THEN α ERROR( 13, TOKEN &" not defined, will define"); R1←INSERT_ENTRY(TOKEN,ID_TYPE_TABLE) β;
get_token;
if token≠"=" THEN ERROR_REJECT(15,"Need ""="" here, continue will insert it");
INSIDE_STRING_DECLARATION←FALSE;
id_list:body[r1]←string_expr;
id_list:type[r1]←string_value;
β;
procedure integer_P;
α ; β;
! abort_P, note_P,comment_P,speed_factor_P;
procedure abort_P;
α ! PRINT/ABORT/PAUSE STATEMENT FOUND;
IF EQU(TOKEN,"PAUSE") THEN
α
ERROR_BUFFER←CURLINER;
p_exp2;
IF EXP_TYPE≠scalar_VALUE
THEN F_STATE(0,1102,"Need a scalar expression here for a PAUSE statement.");
PRINT("(PAUSE "&OUTEXPR&")");
β
ELSE α
PRINT("("&TOKEN&" ");
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"(") THEN
ERROR(1104,"Need left paren here, continue will insert it.");
TOKEN←",";
WHILE EQU(TOKEN,",") DO
α
GET_TOKEN;
IF TYPE_OF_TOKEN=string_token THEN PRINT(dquote&TOKEN&dquote)
ELSE α
REJECT←TRUE;
P_EXP;
β;
GET_TOKEN;
IF ¬EQU(TOKEN,",") AND ¬EQU(TOKEN,";") AND ¬EQU(TOKEN,")") THEN
ERROR_REJECT(1103,"Illegal separator. Continue"&
" will try to insert reasonable separator.");
β;
IF ¬EQU(TOKEN,")") THEN
ERROR(1104,"Need right paren here, continue will insert it.");
SPACING←SPACING-1;
PRINT(")");
β;
β;
procedure note_P;
α
BOOLEAN LPAR; STRING T,T2;
LPAR←FALSE;
T←TOKEN;
GET_TOKEN;
IF EQU(TOKEN,"(") THEN α LPAR←TRUE; GET_TOKEN β;
IF TYPE_OF_TOKEN≠string_token then F_STATE(0,1102,
"Need string expression here for "& token & " statement.")
ELSE
α T2←TOKEN;
IF LPAR THEN α GET_TOKEN; IF ¬EQU(TOKEN,")") THEN ERROR(1234,
"Parenthesis mismatch.") β;
PRINT("( "& T & space & dquote & T2 & dquote & " )");
β;
β;
procedure comment_P;
GARB←READ(semicolon_A_break);
procedure speed_factor_P;
α
GET_TOKEN;
IF ¬TOKEN_EQU("←") THEN ERROR_REJECT(37, "Need ← here");
p_exp2;
IF EXP_TYPE≠SCALAR_VALUE THEN ERROR(36, "Need to have scalar expression for SPEED_FACTOR");
PRINT("(SPEED_FACTOR "&OUTEXPR& " )");
β;
! P_statement execution starts here;
LABEL RE_TRY;
INSIDE_STATEMENT←-100;
GET_TOKEN;
WHILE EQU(TOKEN,"COMMENT") DO
α GARB←READ(semicolon_A_break); GET_TOKEN; β;
! TO GET RID OF DIRECTORY PAGE AMONG OTHER THINGS;
BACKUP_ERROR_BUFFER←ERROR_BUFFER←TOKEN&CURLINER;
GLOBAL_RE_TRY:
RE_TRY:
LABL←CHANGER_HEAD; ! USUALLY NULL EXCEPT WHEN INSIDE A CHANGER.;
CHANGER_HEAD←null; LABEL_TYPE←0;
DIM_PTR←NULL_RECORD;
TRY_AGAIN:
CASE TYPE_OF_TOKEN OF
α
[numeric_token] MODIFY_FLUSH_MACRO([0,1,"Statement can't begin with a scalar"]);
[string_token] MODIFY_FLUSH_MACRO([0,2,"Statement can't begin with a string"]);
[macro_token] MODIFY_FLUSH_MACRO([0,3,"PARSER ERROR, MACRO TOKEN FOUND"]);
[metric_token] IF DIM_PTR=NULL_RECORD
THEN α DIM_PTR←TOKEN_PTR; GET_TOKEN; GOTO TRY_AGAIN; β
ELSE MODIFY_FLUSH_MACRO([0,55,"AMBIGUOUS DIMENSIONS"]);
[id_token] IF DIM_PTR = NULL_RECORD
THEN
α
IF BLOCK_LEVEL_OF_DEFN≠0 OR TOKEN_EQU("BARM","YARM","BHAND","YHAND")
THEN
CASE (ID_TYPE + 3)OF
α
[CM_LABEL_VALUE +3]
[CLC_LABEL_VALUE +3]
[CH_LABEL_VALUE +3]
[LABEL_VALUE +3]
α LABEL_TYPE←ID_TYPE;
IF DEFINED(TOKEN_PTR) THEN ERROR(22,"Label multiply used.");
DEFIN(TOKEN_PTR);
IF EQU(LABL,null) THEN LABL←TOKEN&" " ELSE ERROR(22,"Double label.");
check_next_token(23, NULL ,":");
GET_TOKEN; GO TO TRY_AGAIN;
β;
[form_value +3]
[boole_VALUE +3]
[SCALAR_VALUE +3]
[VECTOR_VALUE +3]
[ROT_VALUE +3]
[FRAME_VALUE +3]
[PLANE_VALUE +3]
[TRANS_VALUE +3]
α STRING ID, AS; RPTR(DIMENS_EXPONENT) ID_DIMEN;INTEGER ID_T,BL;
RPTR(ID_LIST) R1; R1←TOKEN_PTR; BL←BLOCK_LEVEL_OF_DEFN;
ID←TOKEN; ID_T←ID_TYPE; ID_DIMEN←ID_LIST:DIMEN[TOKEN_PTR]; GET_TOKEN;
CASE TOKEN OF
α
["←"]
α STRING SS; GET_TOKEN;
IF ¬EQU(TOKEN,"←")
THEN α AS←"AS ";REJECT←TRUE;
IF ¬BL THEN F_STATE(0,7,"TRYING TO ASSIGN VALUE TO ARM OR DEVICE"); β
ELSE AS←"PAS ";
SS←"("&LABL&AS&id; P_EXP2;
IF ¬CHECK_EXP_TYPE_DIMENS(ID_T,ID_DIMEN,"assignment statement")
THEN ERROR(121,"Type mismatch on assignment.");
DEFIN(R1); PRINT(SS); SPACING←SPACING+1;
PRINT(OUTEXPR); SPACING←SPACING-1; PRINT(")");
β;
["<"]
α STRING TYPE_CLC,CLC_LAB; BOOLEAN TEMP; ! GAS FOUND;
GET_TOKEN; TYPE_CLC←TOKEN;
IF EQU(TOKEN,"<")
THEN
α GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(26,"Need = here. Continue will insert it.");
β
ELSE IF ¬EQU(TOKEN,"=") AND ¬EQU(TOKEN,"≠") THEN F_STATE(0,27,"Bogus assignment.");
GET_TOKEN;
IF ID_TYPE=clc_label_VALUE
THEN
α CLC_LAB←TOKEN; GET_TOKEN;
IF ¬EQU(TOKEN,":")
THEN α REJECT←TRUE; TEMP←FALSE;PRINT("("&LABL&"GAS "&id&" "&TYPE_CLC&" "&CLC_LAB&")"); β
ELSE TEMP←TRUE;
β
ELSE α REJECT←TRUE; CLC_LAB←T_GEN; TEMP←TRUE; PRINT("(CLCLAB "&CLC_LAB&")"); β;
IF TEMP
THEN
α PRINT("("&LABL&"GAS "&id&" "&TYPE_CLC&" ("&CLC_LAB&" CLC");
SPACING←SPACING+1; P_EXP; SPACING←SPACING-1; PRINT("))");
β;
β;
ELSE MODIFY_FLUSH_MACRO([0,0,"Can't start this way"])
β;
β;
[string_VALUE +3]
F_STATE(0,2,"Statement can't begin with a string");
ELSE F_STATE(0,4,"Statement can't begin this way")
β
ELSE MODIFY_FLUSH_MACRO([0,7,"Assignment statement can't begin with predefined constant"]);
β
ELSE ERROR(25, "CANNOT HAVE DIMENSION IN FRONT OF VARIABLE");
[undeclared_token]
α STRING ID, AS; INTEGER ID_T;RPTR(DIMENS_EXPONENT) ID_DIMEN;
RPTR(ID_LIST) POINT; ID←TOKEN; GET_TOKEN;
CASE TOKEN OF
α
["←"]
α STRING SS;GET_TOKEN;
IF ¬EQU(TOKEN,"←")THEN α AS←"AS "; REJECT←TRUE; β ELSE α AS←"PAS "; β;
SS←"("&LABL&AS&id; P_EXP2; ERROR_BUFFER←BACKUP_ERROR_BUFFER;
IF MODIFY_CONTINUE(0,"Undefined variable "&id&crlf&
"Continue will declare it . Modify will allow correction.")
THEN GOTO TRY_AGAIN
ELSE
α POINT←INSERT_ENTRY(ID,ID_TYPE_TABLE);
ID_LIST:TYPE[POINT]←EXP_TYPE; ID_LIST:DIMEN[POINT]←EXP_DIMENS;
IF EXP_TYPE=Trans_VALUE THEN ID_T←frame_VALUE ELSE ID_T←EXP_TYPE;
PRINT("("&DEC_NAME[ID_T]&" "&ID&")");
DEFIN(POINT); PRINT(SS); SPACING←SPACING+1;
PRINT(OUTEXPR); SPACING←SPACING-1; PRINT(")");
β;
β;
["<"]
α STRING TYPE_CLC,CLC_LAB; BOOLEAN TEMP; ! GAS FOUND;
RPTR(ID_LIST) POINT; POINT←INSERT_ENTRY(ID,ID_TYPE_TABLE);
ID_LIST:TYPE[POINT]←trans_VALUE; DEFIN(POINT);
GET_TOKEN; TYPE_CLC←TOKEN;
IF EQU(TOKEN,"<")
THEN
α GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(26,"Need = here. Continue will insert it.");
β
ELSE IF ¬EQU(TOKEN,"=") AND ¬EQU(TOKEN,"≠") THEN F_STATE(0,27,"Bogus assignment.");
GET_TOKEN;
IF ID_TYPE=clc_label_VALUE
THEN
α CLC_LAB←TOKEN; GET_TOKEN;
IF ¬EQU(TOKEN,":")
THEN
α REJECT←TRUE; TEMP←FALSE;
PRINT("("&LABL&"GAS "&id&" "&TYPE_CLC&" "&CLC_LAB&")");
β
ELSE TEMP←TRUE;
β
ELSE α REJECT←TRUE; CLC_LAB←T_GEN; TEMP←TRUE; PRINT("(CLCLAB "&CLC_LAB&")"); β;
IF TEMP
THEN
α PRINT("("&LABL&"GAS "&id&" "&TYPE_CLC&" ("&CLC_LAB&" CLC");
SPACING←SPACING+1; P_EXP; SPACING←SPACING-1; PRINT("))");
β;
β;
ELSE MODIFY_FLUSH_MACRO([0,25,"Can't start statement this way"])
β;
β;
[reserved_token]
α INSIDE_STATEMENT←RESERVED_TOKEN_PTR;
IF (statement_beg ≤ TYPE_OF_RES_WORD ≤ statement_end)
THEN CASE TYPE_OF_RES_WORD - statement_beg OF
α
redefine xx(str)=[redefine xx_temp="str" & "_P"; xx_temp;];
redefine yy(str)=[];
redefine zz(str)=[redefine zz_temp="str" & "_P"; zz_temp;];
statement_definitions;
β
ELSE IF TOKEN_PTR←CHECK_ENTRY(TOKEN,DIMENSION_TYPE_TABLE)
THEN α TYPE_OF_TOKEN←METRIC_TOKEN;
DIM_PTR←TOKEN_PTR; GOTO TRY_AGAIN; β
ELSE MODIFY_FLUSH_MACRO([0,3,"Statement can't begin with <"&TOKEN&">"]);
β
β;
FLUSH:
β "P_STATEMENT";
! execution starts here, initialization;
procedure update_break_RS;
α
SETBREAK(word_R_break, TABLE1, NULL, "INRK");
SETBREAK(word_S_break, TABLE1, NULL, "INSK");
β;
procedure add_to_table1(string s);
α TABLE1←TABLE1&S;
update_break_RS;
β;
procedure remove_from_table1(string s);
α
integer temp;
setbreak(temp←getbreak,null,s,"O");
TABLE1←SCAN(TABLE1,TEMP,BRCHAR);
update_break_RS;
RELBREAK(TEMP);
β;
α "execution"
INITIALIZE←TRUE;
COUNT ← 1000; DELIMITER_1 ← DELIMITER_2 ← 0; top_delimiters ← null_record;
OPEN_BRACE← "{" ;
TABLE1 ← "⊂⊃%,.;:[](){}+-*/#∧∨¬⊗&≤≥<>≠=←↑→?|" & lf & cr & dquote & tab & ff & space & squote ;
SETBREAK(
word_R_break ← getbreak, TABLE1, NULL, "INRK");
SETBREAK(
non_blank_break ← getbreak, space & crlf & ff & tab, NULL, "XNRK");
SETBREAK(
word_S_break ← getbreak, TABLE1, NULL, "INSK");
SETBREAK(
non_digit_break ← getbreak, ".0123456789", NULL, "XRK");
SETBREAK(
close_brace_break← getbreak, "}", NULL, "ISK");
SETBREAK(
quote_break ← getbreak, dquote, NULL, "ISN");
SETBREAK(
semicolon_A_break← getbreak, ";", NULL, "IAK");
SETBREAK(
cr_break ← getbreak, cr, NULL, "IANK");
SETBREAK(
paren_cr_break ← getbreak, "()" & cr, NULL, "IANK");
SETBREAK(
lf_ff_break ← getbreak, lf & ff, NULL, "IANK");
SETBREAK(
semicolon_R_break ← getbreak, ";", NULL, "IRK");
SETBREAK(
omit_break ← getbreak, NULL, ";,." & ff & crlf, "I");
SETBREAK(
tty_input_break ← getbreak,ALT,NULL,"IS");
macro_delimiter_break ← getbreak;
TTYUP(TRUE);
! set up input and output;
if rpgsw then
α
cmd_line ← tmpin("AL", eof);
if eof
then α usererr(0, 1, "TMPIN lost"); rpgsw ← false β
else outstr(crlf & "AL: ");
β;
if ¬rpgsw then α outstr(crlf & "*"); cmd_line ← instrl(cr) β;
BIN_file ← new_record(file); ALL_file ← new_record(file);
SEX_file ← new_record(file); T←TRUE;
while true do
α "command" define want_BAIL=[switch_setting[b_X]];
want_BAIL ← false;
if ¬T then α outstr(crlf & "*"); cmd_line ← instrl(cr) β; T ← false;
PRESENT_file←AL_file ← scan_command(cmd_line, BIN_file, ALL_file);
if file:eof[AL_file] then
α usererr(0, 1, "null input spec"); continue "command" β;
file:mode[AL_file] ← 0; file:in_bfrs[AL_file] ← 12; file:out_bfrs[AL_file] ← 0;
file:def_ext[AL_file] ← "AL";
if ¬got_input(AL_file) then
α outstr(infile & "file not found"); continue "command" β;
if file:name[BIN_file]=null
then if file:name[AL_file]= null
then file:name[BIN_file]←"ALMAIN"
else file:name[BIN_file]←file:name[AL_file];
copy_file_record(SEX_file, BIN_file);
file:mode[SEX_file] ← 0; file:in_bfrs[SEX_file] ← 0;
file:out_bfrs[SEX_file] ← 12; file:ext[SEX_file] ← "SEX";
if file:eof[SEX_file] then
α "null output spec"
file:device[SEX_file] ← "DSK";
if file:name[AL_file]≠null
then file:name[SEX_file] ← file:name[AL_file]
else file:name[SEX_file] ← "ALMAIN" ;
β "null output spec";
if ¬got_output(SEX_file) then
α usererr(0, 1, "can't get output"); continue "command" β;
outfile←make_file_name(SEX_file);
chanin ← file:chn[AL_file]; chanout ← file:chn[SEX_file];
if equ(file:device[PRESENT_file],"TTY")
then
α
CHECK_WANT_COPY;
OUTSTR(CRLF&"Enter input through the keyboard. Terminate with<CONTROL><META><LF>"&CRLF);
β
else
α if typed_page_num then outstr(crlf);
outstr(infile & " 1");
CHANTTYO←-1;
β;
pagenum ← linenum ← sourcelvl ← 0;
typed_page_num ← true;
ifc debug_compile thenc if want_BAIL then BAIL; endc
done "command"
β "command";
! set up predefined dimensions, constants, macros and variables;
redefine zz(temp)=[];
redefine yy(temp,temp2)=[
redefine xx_temp= "DIMENS_EXPONENT:"&"temp"&"["&"temp"&"_DIMENS]←1;";
qq(temp)
xx_temp];
redefine qq(temp)=[redefine xxcount=xxcount+1;
redefine yytemp= "temp"&"_DIMENS←NEW_RECORD(DIMENS_EXPONENT);";
redefine zztemp= "DIMENS_EXPONENT:NAME["&"temp"&"_DIMENS]←"&""""&"temp"&""""&";";
redefine xxtemp(xxxcount)=
"D_TABLE["&"xxxcount" & "] ← INSERT_ENTRY("&""""&"temp"
&""""&",DIMENSION_TYPE_TABLE,"&"temp"&"_DIMENS);";
yytemp
zztemp
xxtemp(xxcount)];
redefine xxcount=-1;
metric_definitions;
INSERT_ENTRY("DIMENSIONLESS",DIMENSION_TYPE_TABLE);
VELOCITY_DIMENS←DIVIDE_DIMENSIONS(DISTANCE_DIMENS,TIME_DIMENS);
TORQUE_DIMENS ← MULTIPLY_DIMENSIONS(FORCE_DIMENS,DISTANCE_DIMENS);
ANGULAR_VELOCITY_DIMENS←DIVIDE_DIMENSIONS(ANGLE_DIMENS,TIME_DIMENS);
FOR I←1 STEP 1 UNTIL const_count DO
α RPTR (ID_LIST) TEMP;
INSERT_ENTRY(PRECONST[I],ID_TYPE_TABLE,TEMP←NEW_RECORD(ID_LIST));
ID_LIST:TYPE[TEMP]←PRECONST_TYPE[I];
ID_LIST:DIMEN[TEMP]←D_TABLE[PRE_DIMENS[I]];
DEFIN(TEMP);
β;
ID_LIST:BODY[CHECK_ENTRY("CRLF",ID_TYPE_TABLE)]← "
";
redefine xx(str1, str2)=[
MACRO_LIST:VALUE[cur_macro←INSERT_ENTRY("str1",MACRO_TYPE_TABLE)]←"str2";
macro_list:delimiters[cur_macro]←"⊂⊃";
cur_macro←null_record;
];
macro_definitions;
INITIALIZE←FALSE;
! PARSE PROGRAM;
RUNTIME←___TIME;
spacing ← 0; print("(PR"); SPACING ← 1; BLOCK_LEVEL←0;
! **********; P_STATEMENT; ! **********;
IF TOP_SOURCE≠NULL_RECORD OR ¬EQU(INPUT(CHANIN,omit_break),null) THEN
ERROR(200,"Misc. garbage found after last end.");
spacing ← 0; print(")");
RUNTIME←___TIME - RUNTIME;
! CLEAN UP;
IF CHANIN≠-1 THEN RELEASE(CHANIN);
WHILE TOP_SOURCE≠NULL DO
α
IF SOURCE_LIST:CHAN[TOP_SOURCE]≠-1 THEN RELEASE(SOURCE_LIST:CHAN[TOP_SOURCE]);
TOP_SOURCE←SOURCE_LIST:NEXT[TOP_SOURCE];
β;
CLOSO(CHANOUT);
CLOSO(CHANLOG);
OUTSTR(CRLF & "PARSING TIME = "&CVS(RUNTIME)& " MSECS");
IF NUM_OF_ERRORS > 0 THEN
α
OUTSTR(crlf & "Number of errors found = "& cvs(NUM_OF_ERRORS));
OUTSTR(CRLF & "Number of errors modified = "& cvs(NUM_OF_ERRORS_MODIFIED));
β;
β "execution";
! SWAP TO AL COMPILER;
α "swap" integer array swap[0:10]; string s; integer tmperr;
if length(file:ext[BIN_file])=0 then file:ext[BIN_file] ← "BIN";
s ← make_file_name(BIN_file) & "," & make_file_name(ALL_file) & "←" & outfile;
α "switches_for_ALC" boolean seen_one; integer i;
seen_one ← false;
for i ← 0 step 1 until switch_max do
if switch_setting[i] then
α
if ¬seen_one then α s ← s & "("; seen_one ← true β;
s ← s & switch_name[i];
β;
if seen_one then s ← s & ")";
β "switches_for_ALC";
tmpout("ALC", s, tmperr);
if tmperr then usererr(0, 1, "Trouble with TMPOUT");
outstr(crlf);
swap[0] ← cvsix("DSK"); swap[1] ← cvfil("ALC.DMP[AL,HE]", swap[2], swap[4]);
swap[3] ← 1; ! start job in RPG mode; swap[5] ← 0;
call(location(swap[0]), "SWAP");
β "swap";
β "hidden_parse";
HIDDEN_PARSE;
END "PARSE";